...
 
Commits (8)
  • Roland Senn's avatar
    Use export list of Main module in function TcRnDriver.hs:check_main (Fix #16453) · 703221f4
    Roland Senn authored
    - Provide the export list of the `Main` module as parameter to the
      `compiler/typecheck/TcRnDriver.hs:check_main` function.
    - Instead of `lookupOccRn_maybe` call the function `lookupInfoOccRn`.
      It returns the list `mains_all` of all the main functions in scope.
    - Select from this list `mains_all` all `main` functions that are in
      the export list of the `Main` module.
    - If this new list contains exactly one single `main` function, then
      typechecking continues.
    - Otherwise issue an appropriate error message.
    703221f4
  • Sebastian Graf's avatar
    Remove -fkill-absence and -fkill-one-shot flags · 3e27205a
    Sebastian Graf authored
    They seem to be a benchmarking vestige of the Cardinality paper and
    probably shouldn't have been merged to HEAD in the first place.
    3e27205a
  • Peter Trommler's avatar
    Do not panic on linker errors · 262e42aa
    Peter Trommler authored
    262e42aa
  • Sylvain Henry's avatar
    DynFlags refactoring III · 0de03cd7
    Sylvain Henry authored
    Use Platform instead of DynFlags when possible:
    * `tARGET_MIN_INT` et al. replaced with `platformMinInt` et al.
    * no more DynFlags in PreRules: added a new `RuleOpts` datatype
    * don't use `wORD_SIZE` in the compiler
    * make `wordAlignment` use `Platform`
    * make `dOUBLE_SIZE` a constant
    
    Metric Decrease:
        T13035
        T1969
    0de03cd7
  • Tristan Cacqueray's avatar
    Base: fix a typo in liftA doc · 7a04920b
    Tristan Cacqueray authored
    This change removes an extra '|' that should not be rendered in
    the liftA documentation.
    
    Tracking: #17929
    7a04920b
  • Tristan Cacqueray's avatar
    Base: add Control.Applicative optional example · 1c5a15f7
    Tristan Cacqueray authored
    This change adds an optional example.
    
    Tracking: #17929
    1c5a15f7
  • Tristan Cacqueray's avatar
    Base: add markup around Except · 6d172e63
    Tristan Cacqueray authored
    6d172e63
  • Simon Peyton Jones's avatar
    Significant refactor of Lint · a262ea49
    Simon Peyton Jones authored
    This refactoring of Lint was triggered by #17923, which is
    fixed by this patch.
    
    The main change is this.  Instead of
       lintType :: Type -> LintM LintedKind
    we now have
       lintType :: Type -> LintM LintedType
    
    Previously, all of typeKind was effectively duplicate in lintType.
    Moreover, since we have an ambient substitution, we still had to
    apply the substition here and there, sometimes more than once. It
    was all very tricky, in the end, and made my head hurt.
    
    Now, lintType returns a fully linted type, with all substitutions
    performed on it.  This is much simpler.
    
    The same thing is needed for Coercions.  Instead of
      lintCoercion :: OutCoercion
                   -> LintM (LintedKind, LintedKind,
                             LintedType, LintedType, Role)
    we now have
      lintCoercion :: Coercion -> LintM LintedCoercion
    
    Much simpler!  The code is shorter and less bug-prone.
    
    There are a lot of knock on effects.  But life is now better.
    a262ea49
...@@ -96,7 +96,7 @@ assembleBCOs ...@@ -96,7 +96,7 @@ assembleBCOs
-> IO CompiledByteCode -> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
itblenv <- mkITbls hsc_env tycons itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos bcos <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos
(bcos',ptrs) <- mallocStrings hsc_env bcos (bcos',ptrs) <- mallocStrings hsc_env bcos
return CompiledByteCode return CompiledByteCode
{ bc_bcos = bcos' { bc_bcos = bcos'
...@@ -151,20 +151,19 @@ mallocStrings hsc_env ulbcos = do ...@@ -151,20 +151,19 @@ mallocStrings hsc_env ulbcos = do
assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO hsc_env pbco = do assembleOneBCO hsc_env pbco = do
ubco <- assembleBCO (hsc_dflags hsc_env) pbco ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco
([ubco'], _ptrs) <- mallocStrings hsc_env [ubco] ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
return ubco' return ubco'
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO { protoBCOName = nm assembleBCO platform (ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs , protoBCOInstrs = instrs
, protoBCOBitmap = bitmap , protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize , protoBCOBitmapSize = bsize
, protoBCOArity = arity }) = do , protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels. -- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs let asm = mapM_ (assembleI platform) instrs
platform = targetPlatform dflags
initial_offset = 0 initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants -- Jump instructions are variable-sized, there are long and short variants
...@@ -347,10 +346,10 @@ largeArg16s platform = case platformWordSize platform of ...@@ -347,10 +346,10 @@ largeArg16s platform = case platformWordSize platform of
PW8 -> 4 PW8 -> 4
PW4 -> 2 PW4 -> 2
assembleI :: DynFlags assembleI :: Platform
-> BCInstr -> BCInstr
-> Assembler () -> Assembler ()
assembleI dflags i = case i of assembleI platform i = case i of
STKCHECK n -> emit bci_STKCHECK [Op n] STKCHECK n -> emit bci_STKCHECK [Op n]
PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
...@@ -365,14 +364,14 @@ assembleI dflags i = case i of ...@@ -365,14 +364,14 @@ assembleI dflags i = case i of
emit bci_PUSH_G [Op p] emit bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
emit bci_PUSH_G [Op p] emit bci_PUSH_G [Op p]
PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco) p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_G [Op p] emit bci_PUSH_G [Op p]
PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco) p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_ALTS [Op p] emit bci_PUSH_ALTS [Op p]
PUSH_ALTS_UNLIFTED proto pk PUSH_ALTS_UNLIFTED proto pk
-> do let ul_bco = assembleBCO dflags proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco) p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p] emit (push_alts pk) [Op p]
PUSH_PAD8 -> emit bci_PUSH_PAD8 [] PUSH_PAD8 -> emit bci_PUSH_PAD8 []
...@@ -443,7 +442,7 @@ assembleI dflags i = case i of ...@@ -443,7 +442,7 @@ assembleI dflags i = case i of
where where
literal (LitLabel fs (Just sz) _) literal (LitLabel fs (Just sz) _)
| platformOS (targetPlatform dflags) == OSMinGW32 | platformOS platform == OSMinGW32
= litlabel (appendFS fs (mkFastString ('@':show sz))) = litlabel (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of -- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci) -- arg words, e.g. foo@8. testcase: ffi012(ghci)
...@@ -469,9 +468,9 @@ assembleI dflags i = case i of ...@@ -469,9 +468,9 @@ assembleI dflags i = case i of
litlabel fs = lit [BCONPtrLbl fs] litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a] addr (RemotePtr a) = words [fromIntegral a]
float = words . mkLitF float = words . mkLitF
double = words . mkLitD dflags double = words . mkLitD platform
int = words . mkLitI int = words . mkLitI
int64 = words . mkLitI64 dflags int64 = words . mkLitI64 platform
words ws = lit (map BCONPtrWord ws) words ws = lit (map BCONPtrWord ws)
word w = words [w] word w = words [w]
...@@ -505,8 +504,8 @@ return_ubx V64 = error "return_ubx: vector" ...@@ -505,8 +504,8 @@ return_ubx V64 = error "return_ubx: vector"
-- bit pattern is correct for the host's word size and endianness. -- bit pattern is correct for the host's word size and endianness.
mkLitI :: Int -> [Word] mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word] mkLitF :: Float -> [Word]
mkLitD :: DynFlags -> Double -> [Word] mkLitD :: Platform -> Double -> [Word]
mkLitI64 :: DynFlags -> Int64 -> [Word] mkLitI64 :: Platform -> Int64 -> [Word]
mkLitF f mkLitF f
= runST (do = runST (do
...@@ -517,9 +516,8 @@ mkLitF f ...@@ -517,9 +516,8 @@ mkLitF f
return [w0 :: Word] return [w0 :: Word]
) )
mkLitD dflags d mkLitD platform d = case platformWordSize platform of
| wORD_SIZE dflags == 4 PW4 -> runST (do
= runST (do
arr <- newArray_ ((0::Int),1) arr <- newArray_ ((0::Int),1)
writeArray arr 0 d writeArray arr 0 d
d_arr <- castSTUArray arr d_arr <- castSTUArray arr
...@@ -527,20 +525,16 @@ mkLitD dflags d ...@@ -527,20 +525,16 @@ mkLitD dflags d
w1 <- readArray d_arr 1 w1 <- readArray d_arr 1
return [w0 :: Word, w1] return [w0 :: Word, w1]
) )
| wORD_SIZE dflags == 8 PW8 -> runST (do
= runST (do
arr <- newArray_ ((0::Int),0) arr <- newArray_ ((0::Int),0)
writeArray arr 0 d writeArray arr 0 d
d_arr <- castSTUArray arr d_arr <- castSTUArray arr
w0 <- readArray d_arr 0 w0 <- readArray d_arr 0
return [w0 :: Word] return [w0 :: Word]
) )
| otherwise
= panic "mkLitD: Bad wORD_SIZE"
mkLitI64 dflags ii mkLitI64 platform ii = case platformWordSize platform of
| wORD_SIZE dflags == 4 PW4 -> runST (do
= runST (do
arr <- newArray_ ((0::Int),1) arr <- newArray_ ((0::Int),1)
writeArray arr 0 ii writeArray arr 0 ii
d_arr <- castSTUArray arr d_arr <- castSTUArray arr
...@@ -548,16 +542,13 @@ mkLitI64 dflags ii ...@@ -548,16 +542,13 @@ mkLitI64 dflags ii
w1 <- readArray d_arr 1 w1 <- readArray d_arr 1
return [w0 :: Word,w1] return [w0 :: Word,w1]
) )
| wORD_SIZE dflags == 8 PW8 -> runST (do
= runST (do
arr <- newArray_ ((0::Int),0) arr <- newArray_ ((0::Int),0)
writeArray arr 0 ii writeArray arr 0 ii
d_arr <- castSTUArray arr d_arr <- castSTUArray arr
w0 <- readArray d_arr 0 w0 <- readArray d_arr 0
return [w0 :: Word] return [w0 :: Word]
) )
| otherwise
= panic "mkLitI64: Bad wORD_SIZE"
mkLitI i = [fromIntegral i :: Word] mkLitI i = [fromIntegral i :: Word]
......
...@@ -88,7 +88,7 @@ lintCmmExpr (CmmLoad expr rep) = do ...@@ -88,7 +88,7 @@ lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr _ <- lintCmmExpr expr
-- Disabled, if we have the inlining phase before the lint phase, -- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY -- we can have funny offsets due to pointer tagging. -- EZY
-- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
-- cmmCheckWordAddress expr -- cmmCheckWordAddress expr
return rep return rep
lintCmmExpr expr@(CmmMachOp op args) = do lintCmmExpr expr@(CmmMachOp op args) = do
...@@ -124,10 +124,10 @@ isOffsetOp _ = False ...@@ -124,10 +124,10 @@ isOffsetOp _ = False
-- check for funny-looking sub-word offsets. -- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e = cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
| isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e = cmmLintDubiousWordOffset e
_cmmCheckWordAddress _ _cmmCheckWordAddress _
= return () = return ()
......
...@@ -542,10 +542,11 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } ...@@ -542,10 +542,11 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-- closure type, live regs -- closure type, live regs
{% liftP . withThisPackage $ \pkg -> {% liftP . withThisPackage $ \pkg ->
do dflags <- getDynFlags do dflags <- getDynFlags
let platform = targetPlatform dflags
live <- sequence $7 live <- sequence $7
let prof = NoProfilingInfo let prof = NoProfilingInfo
-- drop one for the info pointer -- drop one for the info pointer
bitmap = mkLiveness dflags (drop 1 live) bitmap = mkLiveness platform (drop 1 live)
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3, return (mkCmmRetLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
...@@ -1145,15 +1146,15 @@ reserveStackFrame ...@@ -1145,15 +1146,15 @@ reserveStackFrame
-> CmmParse () -> CmmParse ()
reserveStackFrame psize preg body = do reserveStackFrame psize preg body = do
dflags <- getDynFlags dflags <- getDynFlags
let platform = targetPlatform dflags
old_updfr_off <- getUpdFrameOff old_updfr_off <- getUpdFrameOff
reg <- preg reg <- preg
esize <- psize esize <- psize
let platform = targetPlatform dflags
let size = case constantFoldExpr platform esize of let size = case constantFoldExpr platform esize of
CmmLit (CmmInt n _) -> n CmmLit (CmmInt n _) -> n
_other -> pprPanic "CmmParse: not a compile-time integer: " _other -> pprPanic "CmmParse: not a compile-time integer: "
(ppr esize) (ppr esize)
let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size
emitAssign reg (CmmStackSlot Old frame) emitAssign reg (CmmStackSlot Old frame)
withUpdFrameOff frame body withUpdFrameOff frame body
...@@ -1187,7 +1188,8 @@ foreignCall conv_string results_code expr_code args_code safety ret ...@@ -1187,7 +1188,8 @@ foreignCall conv_string results_code expr_code args_code safety ret
expr <- expr_code expr <- expr_code
args <- sequence args_code args <- sequence args_code
let let
expr' = adjCallTarget dflags conv expr args platform = targetPlatform dflags
expr' = adjCallTarget platform conv expr args
(arg_exprs, arg_hints) = unzip args (arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results (res_regs, res_hints) = unzip results
fc = ForeignConvention conv arg_hints res_hints ret fc = ForeignConvention conv arg_hints res_hints ret
...@@ -1230,7 +1232,6 @@ doJumpWithStack expr_code stk_code args_code = do ...@@ -1230,7 +1232,6 @@ doJumpWithStack expr_code stk_code args_code = do
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse () -> CmmParse ()
doCall expr_code res_code args_code = do doCall expr_code res_code args_code = do
dflags <- getDynFlags
expr <- expr_code expr <- expr_code
args <- sequence args_code args <- sequence args_code
ress <- sequence res_code ress <- sequence res_code
...@@ -1238,16 +1239,15 @@ doCall expr_code res_code args_code = do ...@@ -1238,16 +1239,15 @@ doCall expr_code res_code args_code = do
c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
emit c emit c
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-> CmmExpr -> CmmExpr
-- On Windows, we have to add the '@N' suffix to the label when making -- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention. -- a call with the stdcall calling convention.
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args
| platformOS platform == OSMinGW32 | platformOS platform == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType platform e))) where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))
-- c.f. CgForeignCall.emitForeignCall -- c.f. CgForeignCall.emitForeignCall
platform = targetPlatform dflags
adjCallTarget _ _ expr _ adjCallTarget _ _ expr _
= expr = expr
...@@ -1380,7 +1380,8 @@ doSwitch mb_range scrut arms deflt ...@@ -1380,7 +1380,8 @@ doSwitch mb_range scrut arms deflt
let table = M.fromList (concat table_entries) let table = M.fromList (concat table_entries)
dflags <- getDynFlags dflags <- getDynFlags
let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range let platform = targetPlatform dflags
let range = fromMaybe (0, platformMaxWord platform) mb_range
expr <- scrut expr <- scrut
-- ToDo: check for out of range and jump to default if necessary -- ToDo: check for out of range and jump to default if necessary
......
...@@ -489,13 +489,14 @@ regUsedIn platform = regUsedIn_ where ...@@ -489,13 +489,14 @@ regUsedIn platform = regUsedIn_ where
-- --
--------------------------------------------- ---------------------------------------------
mkLiveness :: DynFlags -> [LocalReg] -> Liveness mkLiveness :: Platform -> [LocalReg] -> Liveness
mkLiveness _ [] = [] mkLiveness _ [] = []
mkLiveness dflags (reg:regs) mkLiveness platform (reg:regs)
= bits ++ mkLiveness dflags regs = bits ++ mkLiveness platform regs
where where
sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1) word_size = platformWordSizeInBytes platform
`quot` wORD_SIZE dflags sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)
`quot` word_size
-- number of words, rounded up -- number of words, rounded up
bits = replicate sizeW is_non_ptr -- True <=> Non Ptr bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
module GHC.CmmToAsm.Config module GHC.CmmToAsm.Config
( NCGConfig(..) ( NCGConfig(..)
, ncgWordWidth , ncgWordWidth
, platformWordWidth
) )
where where
...@@ -27,6 +28,10 @@ data NCGConfig = NCGConfig ...@@ -27,6 +28,10 @@ data NCGConfig = NCGConfig
-- | Return Word size -- | Return Word size
ncgWordWidth :: NCGConfig -> Width ncgWordWidth :: NCGConfig -> Width
ncgWordWidth config = case platformWordSize (ncgPlatform config) of ncgWordWidth config = platformWordWidth (ncgPlatform config)
-- | Return Word size
platformWordWidth :: Platform -> Width
platformWordWidth platform = case platformWordSize platform of
PW4 -> W32 PW4 -> W32
PW8 -> W64 PW8 -> W64
...@@ -2185,11 +2185,12 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _ ...@@ -2185,11 +2185,12 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _
return $ code_dst dst_r `appOL` code_src src_r `appOL` return $ code_dst dst_r `appOL` code_src src_r `appOL`
go dst_r src_r tmp_r (fromInteger n) go dst_r src_r tmp_r (fromInteger n)
where where
platform = targetPlatform dflags
-- The number of instructions we will generate (approx). We need 2 -- The number of instructions we will generate (approx). We need 2
-- instructions per move. -- instructions per move.
insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
...@@ -2241,7 +2242,8 @@ genCCall' dflags _ (PrimTarget (MO_Memset align)) _ ...@@ -2241,7 +2242,8 @@ genCCall' dflags _ (PrimTarget (MO_Memset align)) _
return $ code_dst dst_r `appOL` return $ code_dst dst_r `appOL`
go4 dst_r (fromInteger n) go4 dst_r (fromInteger n)
where where
maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported platform = targetPlatform dflags
maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
c2 = c `shiftL` 8 .|. c c2 = c `shiftL` 8 .|. c
...@@ -2884,8 +2886,7 @@ genCCall64' :: ForeignTarget -- function to call ...@@ -2884,8 +2886,7 @@ genCCall64' :: ForeignTarget -- function to call
-> [CmmActual] -- arguments (of mixed type) -> [CmmActual] -- arguments (of mixed type)
-> NatM InstrBlock -> NatM InstrBlock
genCCall64' target dest_regs args = do genCCall64' target dest_regs args = do
config <- getConfig platform <- getPlatform
let platform = ncgPlatform config
-- load up the register arguments -- load up the register arguments
let prom_args = map (maybePromoteCArg platform W32) args let prom_args = map (maybePromoteCArg platform W32) args
...@@ -3046,7 +3047,7 @@ genCCall64' target dest_regs args = do ...@@ -3046,7 +3047,7 @@ genCCall64' target dest_regs args = do
-- Align stack to 16n for calls, assuming a starting stack -- Align stack to 16n for calls, assuming a starting stack
-- alignment of 16n - word_size on procedure entry. Which we -- alignment of 16n - word_size on procedure entry. Which we
-- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
let word_size = platformWordSizeInBytes (ncgPlatform config) let word_size = platformWordSizeInBytes platform
(real_size, adjust_rsp) <- (real_size, adjust_rsp) <-
if (tot_arg_size + word_size) `rem` 16 == 0 if (tot_arg_size + word_size) `rem` 16 == 0
then return (tot_arg_size, nilOL) then return (tot_arg_size, nilOL)
...@@ -3097,7 +3098,7 @@ genCCall64' target dest_regs args = do ...@@ -3097,7 +3098,7 @@ genCCall64' target dest_regs args = do
-- stdcall has callee do it, but is not supported on -- stdcall has callee do it, but is not supported on
-- x86_64 target (see #3336) -- x86_64 target (see #3336)
(if real_size==0 then [] else (if real_size==0 then [] else
[ADD (intFormat (ncgWordWidth config)) (OpImm (ImmInt real_size)) (OpReg esp)]) [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])
++ ++
[DELTA (delta + real_size)] [DELTA (delta + real_size)]
) )
...@@ -3276,10 +3277,10 @@ genSwitch expr targets = do ...@@ -3276,10 +3277,10 @@ genSwitch expr targets = do
let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
offsetReg <- getNewRegNat (intFormat (ncgWordWidth config)) offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))
return $ if is32bit || os == OSDarwin return $ if is32bit || os == OSDarwin
then e_code `appOL` t_code `appOL` toOL [ then e_code `appOL` t_code `appOL` toOL [
ADD (intFormat (ncgWordWidth config)) op (OpReg tableReg), ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),
JMP_TBL (OpReg tableReg) ids rosection lbl JMP_TBL (OpReg tableReg) ids rosection lbl
] ]
else -- HACK: On x86_64 binutils<2.17 is only able to generate else -- HACK: On x86_64 binutils<2.17 is only able to generate
...@@ -3290,7 +3291,7 @@ genSwitch expr targets = do ...@@ -3290,7 +3291,7 @@ genSwitch expr targets = do
-- PprMach.hs/pprDataItem once binutils 2.17 is standard. -- PprMach.hs/pprDataItem once binutils 2.17 is standard.
e_code `appOL` t_code `appOL` toOL [ e_code `appOL` t_code `appOL` toOL [
MOVSxL II32 op (OpReg offsetReg), MOVSxL II32 op (OpReg offsetReg),
ADD (intFormat (ncgWordWidth config)) ADD (intFormat (platformWordWidth platform))
(OpReg offsetReg) (OpReg offsetReg)
(OpReg tableReg), (OpReg tableReg),
JMP_TBL (OpReg tableReg) ids rosection lbl JMP_TBL (OpReg tableReg) ids rosection lbl
......
...@@ -89,7 +89,7 @@ module GHC.Core ( ...@@ -89,7 +89,7 @@ module GHC.Core (
-- * Core rule data types -- * Core rule data types
CoreRule(..), RuleBase, CoreRule(..), RuleBase,
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
RuleEnv(..), mkRuleEnv, emptyRuleEnv, RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv,
-- ** Operations on 'CoreRule's -- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation, ruleArity, ruleName, ruleIdName, ruleActivation,
...@@ -100,6 +100,7 @@ module GHC.Core ( ...@@ -100,6 +100,7 @@ module GHC.Core (
#include "HsVersions.h" #include "HsVersions.h"
import GhcPrelude import GhcPrelude
import GHC.Platform
import CostCentre import CostCentre
import VarEnv( InScopeSet ) import VarEnv( InScopeSet )
...@@ -113,7 +114,6 @@ import Literal ...@@ -113,7 +114,6 @@ import Literal
import GHC.Core.DataCon import GHC.Core.DataCon
import Module import Module
import BasicTypes import BasicTypes
import GHC.Driver.Session
import Outputable import Outputable
import Util import Util
import UniqSet import UniqSet
...@@ -1384,7 +1384,14 @@ data CoreRule ...@@ -1384,7 +1384,14 @@ data CoreRule
} }
-- See Note [Extra args in rule matching] in GHC.Core.Rules -- See Note [Extra args in rule matching] in GHC.Core.Rules
type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -- | Rule options
data RuleOpts = RuleOpts
{ roPlatform :: !Platform -- ^ Target platform
, roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding
, roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled
}
type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
type InScopeEnv = (InScopeSet, IdUnfoldingFun) type InScopeEnv = (InScopeSet, IdUnfoldingFun)
type IdUnfoldingFun = Id -> Unfolding type IdUnfoldingFun = Id -> Unfolding
...@@ -1963,23 +1970,23 @@ mkTyArg ty ...@@ -1963,23 +1970,23 @@ mkTyArg ty
-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' -- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
mkIntLit :: DynFlags -> Integer -> Expr b mkIntLit :: Platform -> Integer -> Expr b
-- | Create a machine integer literal expression of type @Int#@ from an @Int@. -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr' -- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
mkIntLitInt :: DynFlags -> Int -> Expr b mkIntLitInt :: Platform -> Int -> Expr b
mkIntLit dflags n = Lit (mkLitInt dflags n) mkIntLit platform n = Lit (mkLitInt platform n)
mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))
-- | Create a machine word literal expression of type @Word#@ from an @Integer@. -- | Create a machine word literal expression of type @Word#@ from an @Integer@.
-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' -- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
mkWordLit :: DynFlags -> Integer -> Expr b mkWordLit :: Platform -> Integer -> Expr b
-- | Create a machine word literal expression of type @Word#@ from a @Word@. -- | Create a machine word literal expression of type @Word#@ from a @Word@.
-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr' -- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
mkWordLitWord :: DynFlags -> Word -> Expr b mkWordLitWord :: Platform -> Word -> Expr b
mkWordLit dflags w = Lit (mkLitWord dflags w) mkWordLit platform w = Lit (mkLitWord platform w)
mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))
mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
......
This diff is collapsed.
...@@ -63,6 +63,7 @@ import GHC.Core ...@@ -63,6 +63,7 @@ import GHC.Core
import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
import Literal import Literal
import GHC.Driver.Types import GHC.Driver.Types
import GHC.Platform
import TysWiredIn import TysWiredIn
import PrelNames import PrelNames
...@@ -81,7 +82,6 @@ import FastString ...@@ -81,7 +82,6 @@ import FastString
import UniqSupply import UniqSupply
import BasicTypes import BasicTypes
import Util import Util
import GHC.Driver.Session
import Data.List import Data.List
import Data.Char ( ord ) import Data.Char ( ord )
...@@ -250,20 +250,20 @@ castBottomExpr e res_ty ...@@ -250,20 +250,20 @@ castBottomExpr e res_ty
-} -}
-- | Create a 'CoreExpr' which will evaluate to the given @Int@ -- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int
mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@ -- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int
mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i]
-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
mkWordExpr :: DynFlags -> Integer -> CoreExpr mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]
-- | Create a 'CoreExpr' which will evaluate to the given @Word@ -- | Create a 'CoreExpr' which will evaluate to the given @Word@
mkWordExprWord :: DynFlags -> Word -> CoreExpr mkWordExprWord :: Platform -> Word -> CoreExpr
mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ -- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer
......
This diff is collapsed.
...@@ -603,7 +603,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs ...@@ -603,7 +603,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- TODO: Won't the following line unnecessarily trim down arity for join -- TODO: Won't the following line unnecessarily trim down arity for join
-- points returning a lambda in a C(S) context? -- points returning a lambda in a C(S) context?
sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
id' = set_idStrictness env id sig id' = setIdStrictness id sig
-- See Note [NOINLINE and strictness] -- See Note [NOINLINE and strictness]
...@@ -1171,8 +1171,7 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) ...@@ -1171,8 +1171,7 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
findBndrDmd env arg_of_dfun dmd_ty id findBndrDmd env arg_of_dfun dmd_ty id
= (dmd_ty', dmd') = (dmd_ty', dmd')
where where
dmd' = killUsageDemand (ae_dflags env) $ dmd' = strictify $
strictify $
trimToType starting_dmd (findTypeShape fam_envs id_ty) trimToType starting_dmd (findTypeShape fam_envs id_ty)
(dmd_ty', starting_dmd) = peelFV dmd_ty id (dmd_ty', starting_dmd) = peelFV dmd_ty id
...@@ -1191,10 +1190,6 @@ findBndrDmd env arg_of_dfun dmd_ty id ...@@ -1191,10 +1190,6 @@ findBndrDmd env arg_of_dfun dmd_ty id
fam_envs = ae_fam_envs env fam_envs = ae_fam_envs env
set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
set_idStrictness env id sig
= setIdStrictness id (killUsageSig (ae_dflags env) sig)
{- Note [Initialising strictness] {- Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See section 9.2 (Finding fixpoints) of the paper. See section 9.2 (Finding fixpoints) of the paper.
......
This diff is collapsed.
...@@ -13,6 +13,7 @@ module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where ...@@ -13,6 +13,7 @@ module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Driver.Session import GHC.Driver.Session
import GHC.Core.Op.Simplify.Monad import GHC.Core.Op.Simplify.Monad
import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
...@@ -3092,7 +3093,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs ...@@ -3092,7 +3093,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
res_ty = contResultType cont res_ty = contResultType cont
; (floats2, body2) ; (floats2, body2)
<- if exprIsDupable (seDynFlags env) join_body <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body
then return (emptyFloats env, join_body) then return (emptyFloats env, join_body)
else do { join_bndr <- newJoinId [bndr'] res_ty else do { join_bndr <- newJoinId [bndr'] res_ty
; let join_call = App (Var join_bndr) (Var bndr') ; let join_call = App (Var join_bndr) (Var bndr')
...@@ -3175,7 +3176,7 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts ...@@ -3175,7 +3176,7 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- NB: we don't use alt_env further; it has the substEnv for -- NB: we don't use alt_env further; it has the substEnv for
-- the alternatives, and we don't want that -- the alternatives, and we don't want that
; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr') ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')
emptyJoinFloats alts' emptyJoinFloats alts'
; let all_floats = floats `addJoinFloats` join_floats ; let all_floats = floats `addJoinFloats` join_floats
...@@ -3188,11 +3189,11 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts ...@@ -3188,11 +3189,11 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
-- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils
, sc_cont = mkBoringStop (contResultType cont) } ) } , sc_cont = mkBoringStop (contResultType cont) } ) }
mkDupableAlt :: DynFlags -> OutId mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt -> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt) -> SimplM (JoinFloats, OutAlt)
mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs') mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')
| exprIsDupable dflags rhs' -- Note [Small alternative rhs] | exprIsDupable platform rhs' -- Note [Small alternative rhs]
= return (jfloats, (con, bndrs', rhs')) = return (jfloats, (con, bndrs', rhs'))
| otherwise | otherwise
......
...@@ -2152,7 +2152,7 @@ mkCase2 dflags scrut bndr alts_ty alts ...@@ -2152,7 +2152,7 @@ mkCase2 dflags scrut bndr alts_ty alts
[(DEFAULT,_,_)] -> False [(DEFAULT,_,_)] -> False
_ -> True _ -> True
, gopt Opt_CaseFolding dflags , gopt Opt_CaseFolding dflags
, Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut
= do { bndr' <- newId (fsLit "lwild") (exprType scrut') = do { bndr' <- newId (fsLit "lwild") (exprType scrut')
; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
......
...@@ -58,7 +58,7 @@ import NameEnv ...@@ -58,7 +58,7 @@ import NameEnv
import UniqFM import UniqFM
import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX )
import BasicTypes import BasicTypes
import GHC.Driver.Session ( DynFlags ) import GHC.Driver.Session hiding (ruleCheck)
import Outputable import Outputable
import FastString import FastString
import Maybes import Maybes
...@@ -510,7 +510,12 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) ...@@ -510,7 +510,12 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
matchRule dflags rule_env _is_active fn args _rough_args matchRule dflags rule_env _is_active fn args _rough_args
(BuiltinRule { ru_try = match_fn }) (BuiltinRule { ru_try = match_fn })
-- Built-in rules can't be switched off, it seems -- Built-in rules can't be switched off, it seems
= case match_fn dflags rule_env fn args of = let env = RuleOpts
{ roPlatform = targetPlatform dflags
, roNumConstantFolding = gopt Opt_NumConstantFolding dflags
, roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
}
in case match_fn env rule_env fn args of
Nothing -> Nothing Nothing -> Nothing
Just expr -> Just expr Just expr -> Just expr
......
...@@ -7,6 +7,7 @@ The @TyCon@ datatype ...@@ -7,6 +7,7 @@ The @TyCon@ datatype
-} -}
{-# LANGUAGE CPP, FlexibleInstances #-} {-# LANGUAGE CPP, FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Core.TyCon( module GHC.Core.TyCon(
-- * Main TyCon data types -- * Main TyCon data types
...@@ -134,6 +135,7 @@ module GHC.Core.TyCon( ...@@ -134,6 +135,7 @@ module GHC.Core.TyCon(
#include "HsVersions.h" #include "HsVersions.h"
import GhcPrelude import GhcPrelude
import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep import {-# SOURCE #-} GHC.Core.TyCo.Rep
( Kind, Type, PredType, mkForAllTy, mkFunTy ) ( Kind, Type, PredType, mkForAllTy, mkFunTy )
...@@ -152,7 +154,6 @@ import Var ...@@ -152,7 +154,6 @@ import Var
import VarSet import VarSet
import GHC.Core.Class import GHC.Core.Class
import BasicTypes import BasicTypes
import GHC.Driver.Session
import ForeignCall import ForeignCall
import Name import Name
import NameEnv import NameEnv
...@@ -1474,20 +1475,20 @@ isGcPtrRep _ = False ...@@ -1474,20 +1475,20 @@ isGcPtrRep _ = False
-- A PrimRep is compatible with another iff one can be coerced to the other. -- A PrimRep is compatible with another iff one can be coerced to the other.
-- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. -- See Note [bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.
primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool
primRepCompatible dflags rep1 rep2 = primRepCompatible platform rep1 rep2 =
(isUnboxed rep1 == isUnboxed rep2) && (isUnboxed rep1 == isUnboxed rep2) &&
(primRepSizeB dflags rep1 == primRepSizeB dflags rep2) && (primRepSizeB platform rep1 == primRepSizeB platform rep2) &&
(primRepIsFloat rep1 == primRepIsFloat rep2) (primRepIsFloat rep1 == primRepIsFloat rep2)
where where
isUnboxed = not . isGcPtrRep isUnboxed = not . isGcPtrRep
-- More general version of `primRepCompatible` for types represented by zero or -- More general version of `primRepCompatible` for types represented by zero or
-- more than one PrimReps. -- more than one PrimReps.
primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible dflags reps1 reps2 = primRepsCompatible platform reps1 reps2 =
length reps1 == length reps2 && length reps1 == length reps2 &&
and (zipWith (primRepCompatible dflags) reps1 reps2) and (zipWith (primRepCompatible platform) reps1 reps2)
-- | The size of a 'PrimRep' in bytes. -- | The size of a 'PrimRep' in bytes.
-- --
...@@ -1496,24 +1497,25 @@ primRepsCompatible dflags reps1 reps2 = ...@@ -1496,24 +1497,25 @@ primRepsCompatible dflags reps1 reps2 =
-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. -- take only 8 bytes, which for 64-bit arch will be equal to 1 word.
-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are -- See also mkVirtHeapOffsetsWithPadding for details of how data fields are
-- laid out. -- laid out.
primRepSizeB :: DynFlags -> PrimRep -> Int primRepSizeB :: Platform -> PrimRep -> Int
primRepSizeB dflags IntRep = wORD_SIZE dflags primRepSizeB platform = \case
primRepSizeB dflags WordRep = wORD_SIZE dflags IntRep -> platformWordSizeInBytes platform
primRepSizeB _ Int8Rep = 1 WordRep -> platformWordSizeInBytes platform
primRepSizeB _ Int16Rep = 2 Int8Rep -> 1
primRepSizeB _ Int32Rep = 4 Int16Rep -> 2
primRepSizeB _ Int64Rep = wORD64_SIZE Int32Rep -> 4
primRepSizeB _ Word8Rep = 1 Int64Rep -> wORD64_SIZE
primRepSizeB _ Word16Rep = 2 Word8Rep -> 1
primRepSizeB _ Word32Rep = 4 Word16Rep -> 2
primRepSizeB _ Word64Rep = wORD64_SIZE Word32Rep -> 4
primRepSizeB _ FloatRep = fLOAT_SIZE Word64Rep -> wORD64_SIZE
primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags FloatRep -> fLOAT_SIZE
primRepSizeB dflags AddrRep = wORD_SIZE dflags DoubleRep -> dOUBLE_SIZE
primRepSizeB dflags LiftedRep = wORD_SIZE dflags AddrRep -> platformWordSizeInBytes platform
primRepSizeB dflags UnliftedRep = wORD_SIZE dflags LiftedRep -> platformWordSizeInBytes platform
primRepSizeB _ VoidRep = 0 UnliftedRep -> platformWordSizeInBytes platform
primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep VoidRep -> 0
(VecRep len rep) -> len * primElemRepSizeB rep
primElemRepSizeB :: PrimElemRep -> Int primElemRepSizeB :: PrimElemRep -> Int
primElemRepSizeB Int8ElemRep = 1 primElemRepSizeB Int8ElemRep = 1
......
...@@ -2447,7 +2447,7 @@ normally it would make no sense to have ...@@ -2447,7 +2447,7 @@ normally it would make no sense to have
forall r. (ty :: K r) forall r. (ty :: K r)
because the kind of the forall would escape the binding because the kind of the forall would escape the binding
of 'r'. But in this case it's fine because (K r) exapands of 'r'. But in this case it's fine because (K r) exapands
to Type, so we expliclity /permit/ the type to Type, so we explicitly /permit/ the type
forall r. T r forall r. T r
To accommodate such a type, in typeKind (forall a.ty) we use To accommodate such a type, in typeKind (forall a.ty) we use
...@@ -2455,8 +2455,13 @@ occCheckExpand to expand any type synonyms in the kind of 'ty' ...@@ -2455,8 +2455,13 @@ occCheckExpand to expand any type synonyms in the kind of 'ty'
to eliminate 'a'. See kinding rule (FORALL) in to eliminate 'a'. See kinding rule (FORALL) in
Note [Kinding rules for types] Note [Kinding rules for types]
And in TcValidity.checkEscapingKind, we use also use See also
occCheckExpand, for the same reason. * TcUnify.occCheckExpand
* GHC.Core.Utils.coreAltsType
* TcValidity.checkEscapingKind
all of which grapple with with the same problem.
See #14939.
-} -}
----------------------------- -----------------------------
......
...@@ -63,6 +63,7 @@ module GHC.Core.Utils ( ...@@ -63,6 +63,7 @@ module GHC.Core.Utils (
#include "HsVersions.h" #include "HsVersions.h"
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Core import GHC.Core
import PrelNames ( makeStaticName ) import PrelNames ( makeStaticName )
...@@ -87,7 +88,6 @@ import GHC.Core.TyCon ...@@ -87,7 +88,6 @@ import GHC.Core.TyCon
import Unique import Unique
import Outputable import Outputable
import TysPrim import TysPrim
import GHC.Driver.Session
import FastString import FastString
import Maybes import Maybes
import ListSetOps ( minusList ) import ListSetOps ( minusList )
...@@ -1138,8 +1138,8 @@ Note [exprIsDupable] ...@@ -1138,8 +1138,8 @@ Note [exprIsDupable]
and then inlining of case join points and then inlining of case join points
-} -}
exprIsDupable :: DynFlags -> CoreExpr -> Bool exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable dflags e exprIsDupable platform e
= isJust (go dupAppSize e) = isJust (go dupAppSize e)
where where
go :: Int -> CoreExpr -> Maybe Int go :: Int -> CoreExpr -> Maybe Int
...@@ -1149,7 +1149,7 @@ exprIsDupable dflags e ...@@ -1149,7 +1149,7 @@ exprIsDupable dflags e
go n (Tick _ e) = go n e go n (Tick _ e) = go n e
go n (Cast e _) = go n e go n (Cast e _) = go n e
go n (App f a) | Just n' <- go n a = go n' f go n (App f a) | Just n' <- go n a = go n' f
go n (Lit lit) | litIsDupable dflags lit = decrement n go n (Lit lit) | litIsDupable platform lit = decrement n
go _ _ = Nothing go _ _ = Nothing
decrement :: Int -> Maybe Int decrement :: Int -> Maybe Int
......
...@@ -296,11 +296,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis ...@@ -296,11 +296,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
peep [] peep []
= [] = []
argBits :: DynFlags -> [ArgRep] -> [Bool] argBits :: Platform -> [ArgRep] -> [Bool]
argBits _ [] = [] argBits _ [] = []
argBits dflags (rep : args) argBits platform (rep : args)
| isFollowableArg rep = False : argBits dflags args | isFollowableArg rep = False : argBits platform args
| otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- schemeTopBind -- schemeTopBind
...@@ -390,12 +390,12 @@ schemeR_wrk fvs nm original_body (args, body) ...@@ -390,12 +390,12 @@ schemeR_wrk fvs nm original_body (args, body)
-- Stack arguments always take a whole number of words, we never pack -- Stack arguments always take a whole number of words, we never pack
-- them unlike constructor fields. -- them unlike constructor fields.
szsb_args = map (wordsToBytes platform . idSizeW dflags) all_args szsb_args = map (wordsToBytes platform . idSizeW platform) all_args
sum_szsb_args = sum szsb_args sum_szsb_args = sum szsb_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
-- make the arg bitmap -- make the arg bitmap
bits = argBits dflags (reverse (map bcIdArgRep all_args)) bits = argBits platform (reverse (map bcIdArgRep all_args))
bitmap_size = genericLength bits bitmap_size = genericLength bits
bitmap = mkBitmap platform bits bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body body_code <- schemeER_wrk sum_szsb_args p_init body
...@@ -518,8 +518,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) ...@@ -518,8 +518,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- saturated constructor application. -- saturated constructor application.
-- Just allocate the constructor and carry on -- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l alloc_code <- mkConAppCode d s p data_con args_r_to_l
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let platform = targetPlatform dflags
let !d2 = d + wordSize platform let !d2 = d + wordSize platform
body_code <- schemeE d2 s (Map.insert x d2 p) body body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code) return (alloc_code `appOL` body_code)
...@@ -527,10 +526,9 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) ...@@ -527,10 +526,9 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- General case for let. Generates correct, if inefficient, code in -- General case for let. Generates correct, if inefficient, code in
-- all situations. -- all situations.
schemeE d s p (AnnLet binds (_,body)) = do schemeE d s p (AnnLet binds (_,body)) = do
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss AnnRec xs_n_rhss -> unzip xs_n_rhss
platform = targetPlatform dflags
n_binds = genericLength xs n_binds = genericLength xs
fvss = map (fvsToEnv p' . fst) rhss fvss = map (fvsToEnv p' . fst) rhss
...@@ -539,7 +537,7 @@ schemeE d s p (AnnLet binds (_,body)) = do ...@@ -539,7 +537,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
(xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
-- Sizes of free vars -- Sizes of free vars
size_w = trunc16W . idSizeW dflags size_w = trunc16W . idSizeW platform
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs -- the arity of each rhs
...@@ -1029,7 +1027,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ...@@ -1029,7 +1027,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- depth of stack after the return value has been pushed -- depth of stack after the return value has been pushed
d_bndr = d_bndr =
d + ret_frame_size_b + wordsToBytes platform (idSizeW dflags bndr) d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)
-- depth of stack after the extra info table for an unboxed return -- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the -- has been pushed, if any. This is the stack depth at the
...@@ -1236,7 +1234,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ...@@ -1236,7 +1234,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
code_n_reps <- pargs d0 args_r_to_l code_n_reps <- pargs d0 args_r_to_l
let let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l) a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg push_args = concatOL pushs_arg
!d_after_args = d0 + wordsToBytes platform a_reps_sizeW !d_after_args = d0 + wordsToBytes platform a_reps_sizeW
...@@ -1326,12 +1324,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ...@@ -1326,12 +1324,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Push the return placeholder. For a call returning nothing, -- Push the return placeholder. For a call returning nothing,
-- this is a V (tag). -- this is a V (tag).
r_sizeW = repSizeWords dflags r_rep r_sizeW = repSizeWords platform r_rep
d_after_r = d_after_Addr + wordsToBytes platform r_sizeW d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
push_r = push_r =
if returns_void if returns_void
then nilOL then nilOL
else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW)) else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))
-- generate the marshalling code we're going to call -- generate the marshalling code we're going to call
...@@ -1394,11 +1392,11 @@ primRepToFFIType platform r ...@@ -1394,11 +1392,11 @@ primRepToFFIType platform r
-- Make a dummy literal, to be used as a placeholder for FFI return -- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack. -- values on the stack.
mkDummyLiteral :: DynFlags -> PrimRep -> Literal mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral dflags pr mkDummyLiteral platform pr
= case pr of = case pr of
IntRep -> mkLitInt dflags 0 IntRep -> mkLitInt platform 0
WordRep -> mkLitWord dflags 0 WordRep -> mkLitWord platform 0
Int64Rep -> mkLitInt64 0 Int64Rep -> mkLitInt64 0
Word64Rep -> mkLitWord64 0 Word64Rep -> mkLitWord64 0
AddrRep -> LitNullAddr AddrRep -> LitNullAddr
...@@ -1575,15 +1573,13 @@ pushAtom d p (AnnVar var) ...@@ -1575,15 +1573,13 @@ pushAtom d p (AnnVar var)
| Just primop <- isPrimOpId_maybe var | Just primop <- isPrimOpId_maybe var
= do = do
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let platform = targetPlatform dflags
return (unitOL (PUSH_PRIMOP primop), wordSize platform) return (unitOL (PUSH_PRIMOP primop), wordSize platform)
| Just d_v <- lookupBCEnv_maybe var p -- var is a local variable | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable
= do dflags <- getDynFlags = do platform <- targetPlatform <$> getDynFlags
let platform = targetPlatform dflags
let !szb = idSizeCon dflags var let !szb = idSizeCon platform var
with_instr instr = do with_instr instr = do
let !off_b = trunc16B $ d - d_v let !off_b = trunc16B $ d - d_v
return (unitOL (instr off_b), wordSize platform) return (unitOL (instr off_b), wordSize platform)
...@@ -1605,22 +1601,20 @@ pushAtom d p (AnnVar var) ...@@ -1605,22 +1601,20 @@ pushAtom d p (AnnVar var)
| otherwise -- var must be a global variable | otherwise -- var must be a global variable
= do topStrings <- getTopStrings = do topStrings <- getTopStrings
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
case lookupVarEnv topStrings var of case lookupVarEnv topStrings var of
Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $ Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do Nothing -> do
let sz = idSizeCon dflags var let sz = idSizeCon platform var
let platform = targetPlatform dflags
MASSERT( sz == wordSize platform ) MASSERT( sz == wordSize platform )
return (unitOL (PUSH_G (getName var)), sz) return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (AnnLit lit) = do pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let platform = targetPlatform dflags
let code rep let code rep
= let size_words = WordOff (argRepSizeW dflags rep) = let size_words = WordOff (argRepSizeW platform rep)
in return (unitOL (PUSH_UBX lit (trunc16W size_words)), in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
wordsToBytes platform size_words) wordsToBytes platform size_words)
...@@ -1659,8 +1653,8 @@ pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = ...@@ -1659,8 +1653,8 @@ pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
pushConstrAtom d p (AnnVar v) pushConstrAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon dflags v let !szb = idSizeCon platform v
done instr = do done instr = do
let !off = trunc16B $ d - d_v let !off = trunc16B $ d - d_v
return (unitOL (instr off), szb) return (unitOL (instr off), szb)
...@@ -1824,11 +1818,11 @@ instance Outputable Discr where ...@@ -1824,11 +1818,11 @@ instance Outputable Discr where
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup lookupBCEnv_maybe = Map.lookup
idSizeW :: DynFlags -> Id -> WordOff idSizeW :: Platform -> Id -> WordOff
idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep
idSizeCon :: DynFlags -> Id -> ByteOff idSizeCon :: Platform -> Id -> ByteOff
idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
bcIdArgRep :: Id -> ArgRep bcIdArgRep :: Id -> ArgRep
bcIdArgRep = toArgRep . bcIdPrimRep bcIdArgRep = toArgRep . bcIdPrimRep
...@@ -1840,8 +1834,8 @@ bcIdPrimRep id ...@@ -1840,8 +1834,8 @@ bcIdPrimRep id
| otherwise | otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
repSizeWords :: DynFlags -> PrimRep -> WordOff repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep) repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)
isFollowableArg :: ArgRep -> Bool isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True isFollowableArg P = True
......
...@@ -608,11 +608,11 @@ coreToStgArgs (arg : args) = do -- Non-type argument ...@@ -608,11 +608,11 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- or foreign call. -- or foreign call.
-- Wanted: a better solution than this hacky warning -- Wanted: a better solution than this hacky warning
dflags <- getDynFlags platform <- targetPlatform <$> getDynFlags
let let
arg_rep = typePrimRep (exprType arg) arg_rep = typePrimRep (exprType arg)
stg_arg_rep = typePrimRep (stgArgType stg_arg) stg_arg_rep = typePrimRep (stgArgType stg_arg)
bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep) bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
return (stg_arg : stg_args, ticks ++ aticks) return (stg_arg : stg_args, ticks ++ aticks)
......
...@@ -18,6 +18,7 @@ module GHC.CoreToStg.Prep ( ...@@ -18,6 +18,7 @@ module GHC.CoreToStg.Prep (
#include "HsVersions.h" #include "HsVersions.h"
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Core.Op.OccurAnal import GHC.Core.Op.OccurAnal
...@@ -574,10 +575,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) ...@@ -574,10 +575,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
cpeRhsE env (Lit (LitNumber LitNumInteger i _)) cpeRhsE env (Lit (LitNumber LitNumInteger i _))
= cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) = cpeRhsE env (cvtLitInteger (targetPlatform (cpe_dynFlags env)) (getMkIntegerId env)
(cpe_integerSDataCon env) i) (cpe_integerSDataCon env) i)
cpeRhsE env (Lit (LitNumber LitNumNatural i _)) cpeRhsE env (Lit (LitNumber LitNumNatural i _))
= cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env) = cpeRhsE env (cvtLitNatural (targetPlatform (cpe_dynFlags env)) (getMkNaturalId env)
(cpe_naturalSDataCon env) i) (cpe_naturalSDataCon env) i)
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(Var {}) = cpeApp env expr
...@@ -652,17 +653,17 @@ cpeRhsE env (Case scrut bndr ty alts) ...@@ -652,17 +653,17 @@ cpeRhsE env (Case scrut bndr ty alts)
; rhs' <- cpeBodyNF env2 rhs ; rhs' <- cpeBodyNF env2 rhs
; return (con, bs', rhs') } ; return (con, bs', rhs') }
cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr
-- Here we convert a literal Integer to the low-level -- Here we convert a literal Integer to the low-level
-- representation. Exactly how we do this depends on the -- representation. Exactly how we do this depends on the
-- library that implements Integer. If it's GMP we -- library that implements Integer. If it's GMP we
-- use the S# data constructor for small literals. -- use the S# data constructor for small literals.
-- See Note [Integer literals] in Literal -- See Note [Integer literals] in Literal
cvtLitInteger dflags _ (Just sdatacon) i cvtLitInteger platform _ (Just sdatacon) i
| inIntRange dflags i -- Special case for small integers | platformInIntRange platform i -- Special case for small integers
= mkConApp sdatacon [Lit (mkLitInt dflags i)] = mkConApp sdatacon [Lit (mkLitInt platform i)]
cvtLitInteger dflags mk_integer _ i cvtLitInteger platform mk_integer _ i
= mkApps (Var mk_integer) [isNonNegative, ints] = mkApps (Var mk_integer) [isNonNegative, ints]
where isNonNegative = if i < 0 then mkConApp falseDataCon [] where isNonNegative = if i < 0 then mkConApp falseDataCon []
else mkConApp trueDataCon [] else mkConApp trueDataCon []
...@@ -670,25 +671,25 @@ cvtLitInteger dflags mk_integer _ i ...@@ -670,25 +671,25 @@ cvtLitInteger dflags mk_integer _ i
f 0 = [] f 0 = []
f x = let low = x .&. mask f x = let low = x .&. mask
high = x `shiftR` bits high = x `shiftR` bits
in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high
bits = 31 bits = 31
mask = 2 ^ bits - 1 mask = 2 ^ bits - 1
cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr
-- Here we convert a literal Natural to the low-level -- Here we convert a literal Natural to the low-level
-- representation. -- representation.
-- See Note [Natural literals] in Literal -- See Note [Natural literals] in Literal
cvtLitNatural dflags _ (Just sdatacon) i cvtLitNatural platform _ (Just sdatacon) i
| inWordRange dflags i -- Special case for small naturals | platformInWordRange platform i -- Special case for small naturals
= mkConApp sdatacon [Lit (mkLitWord dflags i)] = mkConApp sdatacon [Lit (mkLitWord platform i)]
cvtLitNatural dflags mk_natural _ i cvtLitNatural platform mk_natural _ i
= mkApps (Var mk_natural) [words] = mkApps (Var mk_natural) [words]
where words = mkListExpr wordTy (f i) where words = mkListExpr wordTy (f i)
f 0 = [] f 0 = []
f x = let low = x .&. mask f x = let low = x .&. mask
high = x `shiftR` bits high = x `shiftR` bits
in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high
bits = 32 bits = 32
mask = 2 ^ bits - 1 mask = 2 ^ bits - 1
......
...@@ -203,7 +203,6 @@ module GHC.Driver.Session ( ...@@ -203,7 +203,6 @@ module GHC.Driver.Session (
wordAlignment, wordAlignment,
tAG_MASK, tAG_MASK,
mAX_PTR_TAG, mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,
...@@ -292,13 +291,11 @@ import Control.Monad.Trans.Except ...@@ -292,13 +291,11 @@ import Control.Monad.Trans.Except
import Data.Ord import Data.Ord
import Data.Bits import Data.Bits
import Data.Char import Data.Char
import Data.Int
import Data.List import Data.List
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Word
import System.FilePath import System.FilePath
import System.Directory import System.Directory
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
...@@ -3568,8 +3565,6 @@ fFlagsDeps = [ ...@@ -3568,8 +3565,6 @@ fFlagsDeps = [
flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified,
flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, flagSpec "irrefutable-tuples" Opt_IrrefutableTuples,
flagSpec "keep-going" Opt_KeepGoing, flagSpec "keep-going" Opt_KeepGoing,
flagSpec "kill-absence" Opt_KillAbsence,
flagSpec "kill-one-shot" Opt_KillOneShot,
flagSpec "late-dmd-anal" Opt_LateDmdAnal, flagSpec "late-dmd-anal" Opt_LateDmdAnal,
flagSpec "late-specialise" Opt_LateSpecialise, flagSpec "late-specialise" Opt_LateSpecialise,
flagSpec "liberate-case" Opt_LiberateCase, flagSpec "liberate-case" Opt_LiberateCase,
...@@ -4917,10 +4912,11 @@ compilerInfo dflags ...@@ -4917,10 +4912,11 @@ compilerInfo dflags
#include "GHCConstantsHaskellWrappers.hs" #include "GHCConstantsHaskellWrappers.hs"
bLOCK_SIZE_W :: DynFlags -> Int bLOCK_SIZE_W :: DynFlags -> Int
bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform
where platform = targetPlatform dflags
wordAlignment :: DynFlags -> Alignment wordAlignment :: Platform -> Alignment
wordAlignment dflags = alignmentOf (wORD_SIZE dflags) wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)
tAG_MASK :: DynFlags -> Int tAG_MASK :: DynFlags -> Int
tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
...@@ -4928,22 +4924,6 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 ...@@ -4928,22 +4924,6 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
mAX_PTR_TAG :: DynFlags -> Int mAX_PTR_TAG :: DynFlags -> Int
mAX_PTR_TAG = tAG_MASK mAX_PTR_TAG = tAG_MASK
-- Might be worth caching these in targetPlatform?
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer
tARGET_MIN_INT dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (minBound :: Int32)
PW8 -> toInteger (minBound :: Int64)
tARGET_MAX_INT dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (maxBound :: Int32)
PW8 -> toInteger (maxBound :: Int64)
tARGET_MAX_WORD dflags
= case platformWordSize (targetPlatform dflags) of
PW4 -> toInteger (maxBound :: Word32)
PW8 -> toInteger (maxBound :: Word64)
{- ----------------------------------------------------------------------------- {- -----------------------------------------------------------------------------
Note [DynFlags consistency] Note [DynFlags consistency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -488,6 +488,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do ...@@ -488,6 +488,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
makeStaticId <- dsLookupGlobalId makeStaticName makeStaticId <- dsLookupGlobalId makeStaticName
dflags <- getDynFlags dflags <- getDynFlags
let platform = targetPlatform dflags
let (line, col) = case loc of let (line, col) = case loc of
RealSrcSpan r _ -> RealSrcSpan r _ ->
( srcLocLine $ realSrcSpanStart r ( srcLocLine $ realSrcSpanStart r
...@@ -496,7 +497,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do ...@@ -496,7 +497,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
_ -> (0, 0) _ -> (0, 0)
srcLoc = mkCoreConApps (tupleDataCon Boxed 2) srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
[ Type intTy , Type intTy [ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col , mkIntExprInt platform line, mkIntExprInt platform col
] ]
putSrcSpanDs loc $ return $ putSrcSpanDs loc $ return $
...@@ -890,7 +891,8 @@ dsExplicitList elt_ty Nothing xs ...@@ -890,7 +891,8 @@ dsExplicitList elt_ty Nothing xs
dsExplicitList elt_ty (Just fln) xs dsExplicitList elt_ty (Just fln) xs
= do { list <- dsExplicitList elt_ty Nothing xs = do { list <- dsExplicitList elt_ty Nothing xs
; dflags <- getDynFlags ; dflags <- getDynFlags
; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] } ; let platform = targetPlatform dflags
; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] }
dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq expr (From from) dsArithSeq expr (From from)
......