diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-11 19:14:11 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-03-25 22:42:02 -0400 |
| commit | 0de03cd78729dc58a846c64b645e71057ec5d24e (patch) | |
| tree | 4d893f44db3fa94094376cf4fcad9a1a832ee261 | |
| parent | 262e42aa34c4d5705c8d011907c351497dd4e862 (diff) | |
| download | haskell-0de03cd78729dc58a846c64b645e71057ec5d24e.tar.gz | |
DynFlags refactoring III
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
48 files changed, 980 insertions, 927 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index d9ab36704d..264dcdf980 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -96,7 +96,7 @@ assembleBCOs -> IO CompiledByteCode assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do 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 return CompiledByteCode { bc_bcos = bcos' @@ -151,20 +151,19 @@ mallocStrings hsc_env ulbcos = do assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO 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] return ubco' -assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO dflags (ProtoBCO { protoBCOName = nm +assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO platform (ProtoBCO { protoBCOName = nm , protoBCOInstrs = instrs , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize , protoBCOArity = arity }) = do -- 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 -- Jump instructions are variable-sized, there are long and short variants @@ -347,10 +346,10 @@ largeArg16s platform = case platformWordSize platform of PW8 -> 4 PW4 -> 2 -assembleI :: DynFlags +assembleI :: Platform -> BCInstr -> Assembler () -assembleI dflags i = case i of +assembleI platform i = case i of STKCHECK n -> emit bci_STKCHECK [Op n] PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] @@ -365,14 +364,14 @@ assembleI dflags i = case i of emit bci_PUSH_G [Op p] PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) 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) 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) emit bci_PUSH_ALTS [Op p] 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) emit (push_alts pk) [Op p] PUSH_PAD8 -> emit bci_PUSH_PAD8 [] @@ -443,7 +442,7 @@ assembleI dflags i = case i of where literal (LitLabel fs (Just sz) _) - | platformOS (targetPlatform dflags) == OSMinGW32 + | platformOS platform == OSMinGW32 = litlabel (appendFS fs (mkFastString ('@':show sz))) -- On Windows, stdcall labels have a suffix indicating the no. of -- arg words, e.g. foo@8. testcase: ffi012(ghci) @@ -469,9 +468,9 @@ assembleI dflags i = case i of litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a] float = words . mkLitF - double = words . mkLitD dflags + double = words . mkLitD platform int = words . mkLitI - int64 = words . mkLitI64 dflags + int64 = words . mkLitI64 platform words ws = lit (map BCONPtrWord ws) word w = words [w] @@ -505,8 +504,8 @@ return_ubx V64 = error "return_ubx: vector" -- bit pattern is correct for the host's word size and endianness. mkLitI :: Int -> [Word] mkLitF :: Float -> [Word] -mkLitD :: DynFlags -> Double -> [Word] -mkLitI64 :: DynFlags -> Int64 -> [Word] +mkLitD :: Platform -> Double -> [Word] +mkLitI64 :: Platform -> Int64 -> [Word] mkLitF f = runST (do @@ -517,9 +516,8 @@ mkLitF f return [w0 :: Word] ) -mkLitD dflags d - | wORD_SIZE dflags == 4 - = runST (do +mkLitD platform d = case platformWordSize platform of + PW4 -> runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 d d_arr <- castSTUArray arr @@ -527,20 +525,16 @@ mkLitD dflags d w1 <- readArray d_arr 1 return [w0 :: Word, w1] ) - | wORD_SIZE dflags == 8 - = runST (do + PW8 -> runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 d d_arr <- castSTUArray arr w0 <- readArray d_arr 0 return [w0 :: Word] ) - | otherwise - = panic "mkLitD: Bad wORD_SIZE" -mkLitI64 dflags ii - | wORD_SIZE dflags == 4 - = runST (do +mkLitI64 platform ii = case platformWordSize platform of + PW4 -> runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 ii d_arr <- castSTUArray arr @@ -548,16 +542,13 @@ mkLitI64 dflags ii w1 <- readArray d_arr 1 return [w0 :: Word,w1] ) - | wORD_SIZE dflags == 8 - = runST (do + PW8 -> runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 ii d_arr <- castSTUArray arr w0 <- readArray d_arr 0 return [w0 :: Word] ) - | otherwise - = panic "mkLitI64: Bad wORD_SIZE" mkLitI i = [fromIntegral i :: Word] diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index 5386f4421d..3a96e82054 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -88,7 +88,7 @@ lintCmmExpr (CmmLoad expr rep) = do _ <- lintCmmExpr expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY - -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ + -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $ -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do @@ -124,10 +124,10 @@ isOffsetOp _ = False -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _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 _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 _cmmCheckWordAddress _ = return () diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 8609ca4a3a..6b07af8859 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -542,10 +542,11 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } -- closure type, live regs {% liftP . withThisPackage $ \pkg -> do dflags <- getDynFlags + let platform = targetPlatform dflags live <- sequence $7 let prof = NoProfilingInfo -- drop one for the info pointer - bitmap = mkLiveness dflags (drop 1 live) + bitmap = mkLiveness platform (drop 1 live) rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 @@ -1145,15 +1146,15 @@ reserveStackFrame -> CmmParse () reserveStackFrame psize preg body = do dflags <- getDynFlags + let platform = targetPlatform dflags old_updfr_off <- getUpdFrameOff reg <- preg esize <- psize - let platform = targetPlatform dflags let size = case constantFoldExpr platform esize of CmmLit (CmmInt n _) -> n _other -> pprPanic "CmmParse: not a compile-time integer: " (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) withUpdFrameOff frame body @@ -1187,7 +1188,8 @@ foreignCall conv_string results_code expr_code args_code safety ret expr <- expr_code args <- sequence args_code let - expr' = adjCallTarget dflags conv expr args + platform = targetPlatform dflags + expr' = adjCallTarget platform conv expr args (arg_exprs, arg_hints) = unzip args (res_regs, res_hints) = unzip results fc = ForeignConvention conv arg_hints res_hints ret @@ -1230,7 +1232,6 @@ doJumpWithStack expr_code stk_code args_code = do doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] -> CmmParse () doCall expr_code res_code args_code = do - dflags <- getDynFlags expr <- expr_code args <- sequence args_code ress <- sequence res_code @@ -1238,16 +1239,15 @@ doCall expr_code res_code args_code = do c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] emit c -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] +adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. -adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args +adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args | platformOS platform == OSMinGW32 = 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 - platform = targetPlatform dflags adjCallTarget _ _ expr _ = expr @@ -1380,7 +1380,8 @@ doSwitch mb_range scrut arms deflt let table = M.fromList (concat table_entries) 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 -- ToDo: check for out of range and jump to default if necessary diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 4071bda9d5..90cbaffd5f 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -489,13 +489,14 @@ regUsedIn platform = regUsedIn_ where -- --------------------------------------------- -mkLiveness :: DynFlags -> [LocalReg] -> Liveness +mkLiveness :: Platform -> [LocalReg] -> Liveness mkLiveness _ [] = [] -mkLiveness dflags (reg:regs) - = bits ++ mkLiveness dflags regs +mkLiveness platform (reg:regs) + = bits ++ mkLiveness platform regs where - sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1) - `quot` wORD_SIZE dflags + word_size = platformWordSizeInBytes platform + sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1) + `quot` word_size -- number of words, rounded up bits = replicate sizeW is_non_ptr -- True <=> Non Ptr diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs index 2df3655948..1ed66f47d3 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -2,6 +2,7 @@ module GHC.CmmToAsm.Config ( NCGConfig(..) , ncgWordWidth + , platformWordWidth ) where @@ -27,6 +28,10 @@ data NCGConfig = NCGConfig -- | Return Word size 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 PW8 -> W64 diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index bf282fcac4..deabf01425 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2185,11 +2185,12 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _ return $ code_dst dst_r `appOL` code_src src_r `appOL` go dst_r src_r tmp_r (fromInteger n) where + platform = targetPlatform dflags -- The number of instructions we will generate (approx). We need 2 -- instructions per move. 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 format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment @@ -2241,7 +2242,8 @@ genCCall' dflags _ (PrimTarget (MO_Memset align)) _ return $ code_dst dst_r `appOL` go4 dst_r (fromInteger n) 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 format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment c2 = c `shiftL` 8 .|. c @@ -2884,8 +2886,7 @@ genCCall64' :: ForeignTarget -- function to call -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall64' target dest_regs args = do - config <- getConfig - let platform = ncgPlatform config + platform <- getPlatform -- load up the register arguments let prom_args = map (maybePromoteCArg platform W32) args @@ -3046,7 +3047,7 @@ genCCall64' target dest_regs args = do -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- 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) <- if (tot_arg_size + word_size) `rem` 16 == 0 then return (tot_arg_size, nilOL) @@ -3097,7 +3098,7 @@ genCCall64' target dest_regs args = do -- stdcall has callee do it, but is not supported on -- x86_64 target (see #3336) (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)] ) @@ -3276,10 +3277,10 @@ genSwitch expr targets = do let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) - offsetReg <- getNewRegNat (intFormat (ncgWordWidth config)) + offsetReg <- getNewRegNat (intFormat (platformWordWidth platform)) return $ if is32bit || os == OSDarwin 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 ] else -- HACK: On x86_64 binutils<2.17 is only able to generate @@ -3290,7 +3291,7 @@ genSwitch expr targets = do -- PprMach.hs/pprDataItem once binutils 2.17 is standard. e_code `appOL` t_code `appOL` toOL [ MOVSxL II32 op (OpReg offsetReg), - ADD (intFormat (ncgWordWidth config)) + ADD (intFormat (platformWordWidth platform)) (OpReg offsetReg) (OpReg tableReg), JMP_TBL (OpReg tableReg) ids rosection lbl diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 79e71f9526..931fa5ae86 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -89,7 +89,7 @@ module GHC.Core ( -- * Core rule data types CoreRule(..), RuleBase, RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), mkRuleEnv, emptyRuleEnv, + RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv, -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, @@ -100,6 +100,7 @@ module GHC.Core ( #include "HsVersions.h" import GhcPrelude +import GHC.Platform import CostCentre import VarEnv( InScopeSet ) @@ -113,7 +114,6 @@ import Literal import GHC.Core.DataCon import Module import BasicTypes -import GHC.Driver.Session import Outputable import Util import UniqSet @@ -1384,7 +1384,14 @@ data CoreRule } -- 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 IdUnfoldingFun = Id -> Unfolding @@ -1963,23 +1970,23 @@ mkTyArg ty -- | 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' -mkIntLit :: DynFlags -> Integer -> Expr b +mkIntLit :: Platform -> Integer -> Expr b -- | 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' -mkIntLitInt :: DynFlags -> Int -> Expr b +mkIntLitInt :: Platform -> Int -> Expr b -mkIntLit dflags n = Lit (mkLitInt dflags n) -mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) +mkIntLit platform n = Lit (mkLitInt platform n) +mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n)) -- | 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' -mkWordLit :: DynFlags -> Integer -> Expr b +mkWordLit :: Platform -> Integer -> Expr b -- | 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' -mkWordLitWord :: DynFlags -> Word -> Expr b +mkWordLitWord :: Platform -> Word -> Expr b -mkWordLit dflags w = Lit (mkLitWord dflags w) -mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) +mkWordLit platform w = Lit (mkLitWord platform w) +mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w)) mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b7813eb667..47a0a9cd2d 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1912,11 +1912,11 @@ lintCoercion co@(UnivCo prov r ty1 ty2) validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2 - = do { dflags <- getDynFlags + = do { platform <- targetPlatform <$> getDynFlags ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) (report "between unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeB dflags rep1 - == TyCon.primRepSizeB dflags rep2) + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) (report "between unboxed values of different size") ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) (TyCon.primRepIsFloat rep2) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 538344b946..d1fe1b0aa1 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -63,6 +63,7 @@ import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) import Literal import GHC.Driver.Types +import GHC.Platform import TysWiredIn import PrelNames @@ -81,7 +82,6 @@ import FastString import UniqSupply import BasicTypes import Util -import GHC.Driver.Session import Data.List import Data.Char ( ord ) @@ -250,20 +250,20 @@ castBottomExpr e res_ty -} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] +mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i] -- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] +mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i] -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value -mkWordExpr :: DynFlags -> Integer -> CoreExpr -mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] +mkWordExpr :: Platform -> Integer -> CoreExpr +mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: DynFlags -> Word -> CoreExpr -mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] +mkWordExprWord :: Platform -> Word -> CoreExpr +mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer diff --git a/compiler/GHC/Core/Op/ConstantFold.hs b/compiler/GHC/Core/Op/ConstantFold.hs index ae9ba8f262..126666a509 100644 --- a/compiler/GHC/Core/Op/ConstantFold.hs +++ b/compiler/GHC/Core/Op/ConstantFold.hs @@ -14,6 +14,7 @@ ToDo: {-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} module GHC.Core.Op.ConstantFold @@ -53,7 +54,6 @@ import Name ( Name, nameOccName ) import Outputable import FastString import BasicTypes -import GHC.Driver.Session import GHC.Platform import Util import GHC.Core.Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) @@ -85,229 +85,228 @@ where the (+#) on the rhs is done at compile time That is why these rules are built in here. -} -primOpRules :: Name -> PrimOp -> Maybe CoreRule - -- ToDo: something for integer-shift ops? - -- NotOp -primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] -primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] - --- Int operations -primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identityDynFlags zeroi - , numFoldingRules IntAddOp intPrimOps - ] -primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) - , rightIdentityDynFlags zeroi - , equalArgs >> retLit zeroi - , numFoldingRules IntSubOp intPrimOps - ] -primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) - , identityCDynFlags zeroi ] -primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) - , rightIdentityCDynFlags zeroi - , equalArgs >> retLitNoC zeroi ] -primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) - , zeroElem zeroi - , identityDynFlags onei - , numFoldingRules IntMulOp intPrimOps - ] -primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) - , leftZero zeroi - , rightIdentityDynFlags onei - , equalArgs >> retLit onei ] -primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) - , leftZero zeroi - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onei dflags) - retLit zeroi - , equalArgs >> retLit zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) - , idempotent - , zeroElem zeroi ] -primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) - , idempotent - , identityDynFlags zeroi ] -primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) - , identityDynFlags zeroi - , equalArgs >> retLit zeroi ] -primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotIOp ] -primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp IntNegOp ] -primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) - , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical - , rightIdentityDynFlags zeroi ] - --- Word operations -primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identityDynFlags zerow - , numFoldingRules WordAddOp wordPrimOps - ] -primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) - , rightIdentityDynFlags zerow - , equalArgs >> retLit zerow - , numFoldingRules WordSubOp wordPrimOps - ] -primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) - , identityCDynFlags zerow ] -primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) - , rightIdentityCDynFlags zerow - , equalArgs >> retLitNoC zerow ] -primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) - , identityDynFlags onew - , numFoldingRules WordMulOp wordPrimOps - ] -primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentityDynFlags onew ] -primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) - , leftZero zerow - , do l <- getLiteral 1 - dflags <- getDynFlags - guard (l == onew dflags) - retLit zerow - , equalArgs >> retLit zerow ] -primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) - , idempotent - , zeroElem zerow ] -primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) - , idempotent - , identityDynFlags zerow ] -primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) - , identityDynFlags zerow - , equalArgs >> retLit zerow ] -primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp - , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] - --- coercions -primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit - , inversePrimOp Int2WordOp ] -primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit - , inversePrimOp Word2IntOp ] -primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit - , subsumedByPrimOp Narrow8IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp - , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] -primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp - , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] -primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit - , subsumedByPrimOp Narrow8IntOp - , subsumedByPrimOp Narrow16IntOp - , subsumedByPrimOp Narrow32IntOp - , removeOp32 - , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] -primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit - , subsumedByPrimOp Narrow8WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp - , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] -primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp - , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] -primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit - , subsumedByPrimOp Narrow8WordOp - , subsumedByPrimOp Narrow16WordOp - , subsumedByPrimOp Narrow32WordOp - , removeOp32 - , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] -primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit - , inversePrimOp ChrOp ] -primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs - guard (litFitsInChar lit) - liftLit int2CharLit - , inversePrimOp OrdOp ] -primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] -primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] -primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] -primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] --- SUP: Not sure what the standard says about precision in the following 2 cases -primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] -primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] - --- Float -primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) - , identity zerof ] -primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) - , rightIdentity zerof ] -primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) - , identity onef - , strengthReduction twof FloatAddOp ] - -- zeroElem zerof doesn't hold because of NaN -primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) - , rightIdentity onef ] -primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp FloatNegOp ] - --- Double -primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) - , identity zerod ] -primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) - , rightIdentity zerod ] -primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) - , identity oned - , strengthReduction twod DoubleAddOp ] - -- zeroElem zerod doesn't hold because of NaN -primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) - , rightIdentity oned ] -primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp - , inversePrimOp DoubleNegOp ] - --- Relational operators - -primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] -primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] - -primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) -primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) -primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) -primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) -primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) -primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) - -primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] -primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] -primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] -primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] -primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] - -primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] - -primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] -primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] - -primOpRules _ _ = Nothing +primOpRules :: Name -> PrimOp -> Maybe CoreRule +primOpRules nm = \case + TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] + DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ] + + -- Int operations + IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityPlatform zeroi + , numFoldingRules IntAddOp intPrimOps + ] + IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityPlatform zeroi + , equalArgs >> retLit zeroi + , numFoldingRules IntSubOp intPrimOps + ] + IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) + , identityCPlatform zeroi ] + IntSubCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) + , rightIdentityCPlatform zeroi + , equalArgs >> retLitNoC zeroi ] + IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem zeroi + , identityPlatform onei + , numFoldingRules IntMulOp intPrimOps + ] + IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero zeroi + , rightIdentityPlatform onei + , equalArgs >> retLit onei ] + IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero zeroi + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onei platform) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] + AndIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] + OrIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityPlatform zeroi ] + XorIOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityPlatform zeroi + , equalArgs >> retLit zeroi ] + NotIOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotIOp ] + IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] + ISllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) + , rightIdentityPlatform zeroi ] + ISraOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) + , rightIdentityPlatform zeroi ] + ISrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical + , rightIdentityPlatform zeroi ] + + -- Word operations + WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityPlatform zerow + , numFoldingRules WordAddOp wordPrimOps + ] + WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityPlatform zerow + , equalArgs >> retLit zerow + , numFoldingRules WordSubOp wordPrimOps + ] + WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) + , identityCPlatform zerow ] + WordSubCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) + , rightIdentityCPlatform zerow + , equalArgs >> retLitNoC zerow ] + WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityPlatform onew + , numFoldingRules WordMulOp wordPrimOps + ] + WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityPlatform onew ] + WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , leftZero zerow + , do l <- getLiteral 1 + platform <- getPlatform + guard (l == onew platform) + retLit zerow + , equalArgs >> retLit zerow ] + AndOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem zerow ] + OrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityPlatform zerow ] + XorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityPlatform zerow + , equalArgs >> retLit zerow ] + NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotOp ] + SllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] + SrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] + + -- coercions + Word2IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit + , inversePrimOp Int2WordOp ] + Int2WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform int2WordLit + , inversePrimOp Word2IntOp ] + Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] + Narrow16IntOp -> mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] + Narrow32IntOp -> mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 + , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] + Narrow8WordOp -> mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] + Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] + Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 + , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] + OrdOp -> mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] + ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] + Float2IntOp -> mkPrimOpRule nm 1 [ liftLit float2IntLit ] + Int2FloatOp -> mkPrimOpRule nm 1 [ liftLit int2FloatLit ] + Double2IntOp -> mkPrimOpRule nm 1 [ liftLit double2IntLit ] + Int2DoubleOp -> mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] + -- SUP: Not sure what the standard says about precision in the following 2 cases + Float2DoubleOp -> mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] + Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ] + + -- Float + FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] + FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] + FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + -- zeroElem zerof doesn't hold because of NaN + FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] + FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] + + -- Double + DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] + DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] + DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + -- zeroElem zerod doesn't hold because of NaN + DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] + DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] + + -- Relational operators + + IntEqOp -> mkRelOpRule nm (==) [ litEq True ] + IntNeOp -> mkRelOpRule nm (/=) [ litEq False ] + CharEqOp -> mkRelOpRule nm (==) [ litEq True ] + CharNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + CharLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + + FloatGtOp -> mkFloatingRelOpRule nm (>) + FloatGeOp -> mkFloatingRelOpRule nm (>=) + FloatLeOp -> mkFloatingRelOpRule nm (<=) + FloatLtOp -> mkFloatingRelOpRule nm (<) + FloatEqOp -> mkFloatingRelOpRule nm (==) + FloatNeOp -> mkFloatingRelOpRule nm (/=) + + DoubleGtOp -> mkFloatingRelOpRule nm (>) + DoubleGeOp -> mkFloatingRelOpRule nm (>=) + DoubleLeOp -> mkFloatingRelOpRule nm (<=) + DoubleLtOp -> mkFloatingRelOpRule nm (<) + DoubleEqOp -> mkFloatingRelOpRule nm (==) + DoubleNeOp -> mkFloatingRelOpRule nm (/=) + + WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ] + WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ] + WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ] + WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ] + WordEqOp -> mkRelOpRule nm (==) [ litEq True ] + WordNeOp -> mkRelOpRule nm (/=) [ litEq False ] + + AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] + + SeqOp -> mkPrimOpRule nm 4 [ seqRule ] + SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] + + _ -> Nothing {- ************************************************************************ @@ -331,10 +330,10 @@ mkRelOpRule nm cmp extra -- compute it for the arbitrary value 'True' -- and use that result equal_rule = do { equalArgs - ; dflags <- getDynFlags + ; platform <- getPlatform ; return (if cmp True True - then trueValInt dflags - else falseValInt dflags) } + then trueValInt platform + else falseValInt platform) } {- Note [Rules for floating-point comparisons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -369,11 +368,11 @@ mkFloatingRelOpRule nm cmp = mkPrimOpRule nm 2 [binaryCmpLit cmp] -- common constants -zeroi, onei, zerow, onew :: DynFlags -> Literal -zeroi dflags = mkLitInt dflags 0 -onei dflags = mkLitInt dflags 1 -zerow dflags = mkLitWord dflags 0 -onew dflags = mkLitWord dflags 1 +zeroi, onei, zerow, onew :: Platform -> Literal +zeroi platform = mkLitInt platform 0 +onei platform = mkLitInt platform 1 +zerow platform = mkLitWord platform 0 +onew platform = mkLitWord platform 1 zerof, onef, twof, zerod, oned, twod :: Literal zerof = mkLitFloat 0.0 @@ -383,12 +382,12 @@ zerod = mkLitDouble 0.0 oned = mkLitDouble 1.0 twod = mkLitDouble 2.0 -cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) +cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool) -> Literal -> Literal -> Maybe CoreExpr -cmpOp dflags cmp = go +cmpOp platform cmp = go where - done True = Just $ trueValInt dflags - done False = Just $ falseValInt dflags + done True = Just $ trueValInt platform + done False = Just $ falseValInt platform -- These compares are at different types go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) @@ -401,117 +400,115 @@ cmpOp dflags cmp = go -------------------------- -negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate -negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) -negOp _ (LitDouble 0.0) = Nothing -negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) -negOp dflags (LitNumber nt i t) - | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) -negOp _ _ = Nothing - -complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement -complementOp dflags (LitNumber nt i t) = - Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) +negOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Negate +negOp env = \case + (LitFloat 0.0) -> Nothing -- can't represent -0.0 as a Rational + (LitFloat f) -> Just (mkFloatVal env (-f)) + (LitDouble 0.0) -> Nothing + (LitDouble d) -> Just (mkDoubleVal env (-d)) + (LitNumber nt i t) + | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i) t)) + _ -> Nothing + +complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement +complementOp env (LitNumber nt i t) = + Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i) t)) complementOp _ _ = Nothing -------------------------- intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr intOp2 = intOp2' . const intOp2' :: (Integral a, Integral b) - => (DynFlags -> a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = - let o = op dflags - in intResult dflags (fromInteger i1 `o` fromInteger i2) + => (RuleOpts -> a -> b -> Integer) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOp2' op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = + let o = op env + in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2) intOp2' _ _ _ _ = Nothing -- Could find LitLit intOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do - intCResult dflags (fromInteger i1 `op` fromInteger i2) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +intOpC2 op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do + intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) intOpC2 _ _ _ _ = Nothing -- Could find LitLit -shiftRightLogical :: DynFlags -> Integer -> Int -> Integer +shiftRightLogical :: Platform -> Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do -- Do this by converting to Word and back. Obviously this won't work for big -- values, but its ok as we use it here -shiftRightLogical dflags x n = - case platformWordSize (targetPlatform dflags) of +shiftRightLogical platform x n = + case platformWordSize platform of PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32) PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64) -------------------------- -retLit :: (DynFlags -> Literal) -> RuleM CoreExpr -retLit l = do dflags <- getDynFlags - return $ Lit $ l dflags +retLit :: (Platform -> Literal) -> RuleM CoreExpr +retLit l = do platform <- getPlatform + return $ Lit $ l platform -retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr -retLitNoC l = do dflags <- getDynFlags - let lit = l dflags +retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr +retLitNoC l = do platform <- getPlatform + let lit = l platform let ty = literalType lit - return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)] + return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)] wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) - = wordResult dflags (fromInteger w1 `op` fromInteger w2) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) + = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) wordOp2 _ _ _ _ = Nothing -- Could find LitLit wordOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) - -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = - wordCResult dflags (fromInteger w1 `op` fromInteger w2) + -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr +wordOpC2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = + wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) wordOpC2 _ _ _ _ = Nothing -- Could find LitLit -shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr +shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- Used for shift primops -- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# -- SllOp, SrlOp :: Word# -> Int# -> Word# shiftRule shift_op - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs ; case e1 of _ | shift_len == 0 -> return e1 -- See Note [Guarding against silly shifts] - | shift_len < 0 || shift_len > wordSizeInBits dflags - -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1) + | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) + -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 (exprType e1) -- Do the shift at type Integer, but shift length is Int Lit (LitNumber nt x t) | 0 < shift_len - , shift_len <= wordSizeInBits dflags - -> let op = shift_op dflags + , shift_len <= toInteger (platformWordSizeInBits platform) + -> let op = shift_op platform y = x `op` fromInteger shift_len - in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) + in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y t)) _ -> mzero } -wordSizeInBits :: DynFlags -> Integer -wordSizeInBits dflags = toInteger (platformWordSizeInBits (targetPlatform dflags)) - -------------------------- floatOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal + -> RuleOpts -> Literal -> Literal -> Maybe (Expr CoreBndr) -floatOp2 op dflags (LitFloat f1) (LitFloat f2) - = Just (mkFloatVal dflags (f1 `op` f2)) +floatOp2 op env (LitFloat f1) (LitFloat f2) + = Just (mkFloatVal env (f1 `op` f2)) floatOp2 _ _ _ _ = Nothing -------------------------- doubleOp2 :: (Rational -> Rational -> Rational) - -> DynFlags -> Literal -> Literal + -> RuleOpts -> Literal -> Literal -> Maybe (Expr CoreBndr) -doubleOp2 op dflags (LitDouble f1) (LitDouble f2) - = Just (mkDoubleVal dflags (f1 `op` f2)) +doubleOp2 op env (LitDouble f1) (LitDouble f2) + = Just (mkDoubleVal env (f1 `op` f2)) doubleOp2 _ _ _ _ = Nothing -------------------------- @@ -541,22 +538,22 @@ litEq :: Bool -- True <=> equality, False <=> inequality -> RuleM CoreExpr litEq is_eq = msum [ do [Lit lit, expr] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr + platform <- getPlatform + do_lit_eq platform lit expr , do [expr, Lit lit] <- getArgs - dflags <- getDynFlags - do_lit_eq dflags lit expr ] + platform <- getPlatform + do_lit_eq platform lit expr ] where - do_lit_eq dflags lit expr = do + do_lit_eq platform lit expr = do guard (not (litIsLifted lit)) return (mkWildCase expr (literalType lit) intPrimTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) where - val_if_eq | is_eq = trueValInt dflags - | otherwise = falseValInt dflags - val_if_neq | is_eq = falseValInt dflags - | otherwise = trueValInt dflags + val_if_eq | is_eq = trueValInt platform + | otherwise = falseValInt platform + val_if_neq | is_eq = falseValInt platform + | otherwise = trueValInt platform -- | Check if there is comparison with minBound or maxBound, that is @@ -564,80 +561,80 @@ litEq is_eq = msum -- minBound, so we can replace such comparison with False. boundsCmp :: Comparison -> RuleM CoreExpr boundsCmp op = do - dflags <- getDynFlags + platform <- getPlatform [a, b] <- getArgs - liftMaybe $ mkRuleFn dflags op a b + liftMaybe $ mkRuleFn platform op a b data Comparison = Gt | Ge | Lt | Le -mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags -mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags -mkRuleFn _ _ _ _ = Nothing - -isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (LitChar c) = c == minBound -isMinBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MIN_INT dflags +mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform +mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform +mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt platform +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: Platform -> Literal -> Bool +isMinBound _ (LitChar c) = c == minBound +isMinBound platform (LitNumber nt i _) = case nt of + LitNumInt -> i == platformMinInt platform LitNumInt64 -> i == toInteger (minBound :: Int64) LitNumWord -> i == 0 LitNumWord64 -> i == 0 LitNumNatural -> i == 0 LitNumInteger -> False -isMinBound _ _ = False +isMinBound _ _ = False -isMaxBound :: DynFlags -> Literal -> Bool -isMaxBound _ (LitChar c) = c == maxBound -isMaxBound dflags (LitNumber nt i _) = case nt of - LitNumInt -> i == tARGET_MAX_INT dflags +isMaxBound :: Platform -> Literal -> Bool +isMaxBound _ (LitChar c) = c == maxBound +isMaxBound platform (LitNumber nt i _) = case nt of + LitNumInt -> i == platformMaxInt platform LitNumInt64 -> i == toInteger (maxBound :: Int64) - LitNumWord -> i == tARGET_MAX_WORD dflags + LitNumWord -> i == platformMaxWord platform LitNumWord64 -> i == toInteger (maxBound :: Word64) LitNumNatural -> False LitNumInteger -> False -isMaxBound _ _ = False +isMaxBound _ _ = False -- | Create an Int literal expression while ensuring the given Integer is in the -- target Int range -intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (intResult' dflags result) +intResult :: Platform -> Integer -> Maybe CoreExpr +intResult platform result = Just (intResult' platform result) -intResult' :: DynFlags -> Integer -> CoreExpr -intResult' dflags result = Lit (mkLitIntWrap dflags result) +intResult' :: Platform -> Integer -> CoreExpr +intResult' platform result = Lit (mkLitIntWrap platform result) -- | Create an unboxed pair of an Int literal expression, ensuring the given -- Integer is in the target Int range and the corresponding overflow flag -- (@0#@/@1#@) if it wasn't. -intCResult :: DynFlags -> Integer -> Maybe CoreExpr -intCResult dflags result = Just (mkPair [Lit lit, Lit c]) +intCResult :: Platform -> Integer -> Maybe CoreExpr +intCResult platform result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] - (lit, b) = mkLitIntWrapC dflags result - c = if b then onei dflags else zeroi dflags + (lit, b) = mkLitIntWrapC platform result + c = if b then onei platform else zeroi platform -- | Create a Word literal expression while ensuring the given Integer is in the -- target Word range -wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (wordResult' dflags result) +wordResult :: Platform -> Integer -> Maybe CoreExpr +wordResult platform result = Just (wordResult' platform result) -wordResult' :: DynFlags -> Integer -> CoreExpr -wordResult' dflags result = Lit (mkLitWordWrap dflags result) +wordResult' :: Platform -> Integer -> CoreExpr +wordResult' platform result = Lit (mkLitWordWrap platform result) -- | Create an unboxed pair of a Word literal expression, ensuring the given -- Integer is in the target Word range and the corresponding carry flag -- (@0#@/@1#@) if it wasn't. -wordCResult :: DynFlags -> Integer -> Maybe CoreExpr -wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) +wordCResult :: Platform -> Integer -> Maybe CoreExpr +wordCResult platform result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] - (lit, b) = mkLitWordWrapC dflags result - c = if b then onei dflags else zeroi dflags + (lit, b) = mkLitWordWrapC platform result + c = if b then onei platform else zeroi platform inversePrimOp :: PrimOp -> RuleM CoreExpr inversePrimOp primop = do @@ -785,7 +782,7 @@ mkBasicRule op_name n_args rm ru_try = runRuleM rm } newtype RuleM r = RuleM - { runRuleM :: DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } + { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } deriving (Functor) instance Applicative RuleM where @@ -794,10 +791,10 @@ instance Applicative RuleM where instance Monad RuleM where RuleM f >>= g - = RuleM $ \dflags iu fn args -> - case f dflags iu fn args of + = RuleM $ \env iu fn args -> + case f env iu fn args of Nothing -> Nothing - Just r -> runRuleM (g r) dflags iu fn args + Just r -> runRuleM (g r) env iu fn args #if !MIN_VERSION_base(4,13,0) fail = MonadFail.fail @@ -808,31 +805,34 @@ instance MonadFail.MonadFail RuleM where instance Alternative RuleM where empty = RuleM $ \_ _ _ _ -> Nothing - RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu fn args -> - f1 dflags iu fn args <|> f2 dflags iu fn args + RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args -> + f1 env iu fn args <|> f2 env iu fn args instance MonadPlus RuleM -instance HasDynFlags RuleM where - getDynFlags = RuleM $ \dflags _ _ _ -> Just dflags +getPlatform :: RuleM Platform +getPlatform = roPlatform <$> getEnv + +getEnv :: RuleM RuleOpts +getEnv = RuleM $ \env _ _ _ -> Just env liftMaybe :: Maybe a -> RuleM a liftMaybe Nothing = mzero liftMaybe (Just x) = return x liftLit :: (Literal -> Literal) -> RuleM CoreExpr -liftLit f = liftLitDynFlags (const f) +liftLit f = liftLitPlatform (const f) -liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr -liftLitDynFlags f = do - dflags <- getDynFlags +liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr +liftLitPlatform f = do + platform <- getPlatform [Lit lit] <- getArgs - return $ Lit (f dflags lit) + return $ Lit (f platform lit) removeOp32 :: RuleM CoreExpr removeOp32 = do - dflags <- getDynFlags - case platformWordSize (targetPlatform dflags) of + platform <- getPlatform + case platformWordSize platform of PW4 -> do [e] <- getArgs return e @@ -855,91 +855,91 @@ getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of (Lit l:_) -> Just l _ -> Nothing -unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr unaryLit op = do - dflags <- getDynFlags + env <- getEnv [Lit l] <- getArgs - liftMaybe $ op dflags (convFloating dflags l) + liftMaybe $ op env (convFloating env l) -binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr binaryLit op = do - dflags <- getDynFlags + env <- getEnv [Lit l1, Lit l2] <- getArgs - liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) + liftMaybe $ op env (convFloating env l1) (convFloating env l2) binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr binaryCmpLit op = do - dflags <- getDynFlags - binaryLit (\_ -> cmpOp dflags op) + platform <- getPlatform + binaryLit (\_ -> cmpOp platform op) leftIdentity :: Literal -> RuleM CoreExpr -leftIdentity id_lit = leftIdentityDynFlags (const id_lit) +leftIdentity id_lit = leftIdentityPlatform (const id_lit) rightIdentity :: Literal -> RuleM CoreExpr -rightIdentity id_lit = rightIdentityDynFlags (const id_lit) +rightIdentity id_lit = rightIdentityPlatform (const id_lit) identity :: Literal -> RuleM CoreExpr identity lit = leftIdentity lit `mplus` rightIdentity lit -leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityDynFlags id_lit = do - dflags <- getDynFlags +leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityPlatform id_lit = do + platform <- getPlatform [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags + guard $ l1 == id_lit platform return e2 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in -- addition to the result, we have to indicate that no carry/overflow occurred. -leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -leftIdentityCDynFlags id_lit = do - dflags <- getDynFlags +leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +leftIdentityCPlatform id_lit = do + platform <- getPlatform [Lit l1, e2] <- getArgs - guard $ l1 == id_lit dflags - let no_c = Lit (zeroi dflags) + guard $ l1 == id_lit platform + let no_c = Lit (zeroi platform) return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) -rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityDynFlags id_lit = do - dflags <- getDynFlags +rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityPlatform id_lit = do + platform <- getPlatform [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags + guard $ l2 == id_lit platform return e1 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in -- addition to the result, we have to indicate that no carry/overflow occurred. -rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -rightIdentityCDynFlags id_lit = do - dflags <- getDynFlags +rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +rightIdentityCPlatform id_lit = do + platform <- getPlatform [e1, Lit l2] <- getArgs - guard $ l2 == id_lit dflags - let no_c = Lit (zeroi dflags) + guard $ l2 == id_lit platform + let no_c = Lit (zeroi platform) return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) -identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityDynFlags lit = - leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit +identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityPlatform lit = + leftIdentityPlatform lit `mplus` rightIdentityPlatform lit -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition -- to the result, we have to indicate that no carry/overflow occurred. -identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr -identityCDynFlags lit = - leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit +identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr +identityCPlatform lit = + leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit -leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr +leftZero :: (Platform -> Literal) -> RuleM CoreExpr leftZero zero = do - dflags <- getDynFlags + platform <- getPlatform [Lit l1, _] <- getArgs - guard $ l1 == zero dflags + guard $ l1 == zero platform return $ Lit l1 -rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr +rightZero :: (Platform -> Literal) -> RuleM CoreExpr rightZero zero = do - dflags <- getDynFlags + platform <- getPlatform [_, Lit l2] <- getArgs - guard $ l2 == zero dflags + guard $ l2 == zero platform return $ Lit l2 -zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr +zeroElem :: (Platform -> Literal) -> RuleM CoreExpr zeroElem lit = leftZero lit `mplus` rightZero lit equalArgs :: RuleM () @@ -953,10 +953,10 @@ nonZeroLit n = getLiteral n >>= guard . not . isZeroLit -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture -- and target architecture here, but it's convenient (and wrong :-). -convFloating :: DynFlags -> Literal -> Literal -convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = +convFloating :: RuleOpts -> Literal -> Literal +convFloating env (LitFloat f) | not (roExcessRationalPrecision env) = LitFloat (toRational (fromRational f :: Float )) -convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = +convFloating env (LitDouble d) | not (roExcessRationalPrecision env) = LitDouble (toRational (fromRational d :: Double)) convFloating _ l = l @@ -1003,9 +1003,9 @@ strengthReduction two_lit add_op = do -- Note [Strength reduction] -- We still need Bool data constructors (True and False) to use in a rule -- for constant folding of equal Strings -trueValInt, falseValInt :: DynFlags -> Expr CoreBndr -trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] -falseValInt dflags = Lit $ zeroi dflags +trueValInt, falseValInt :: Platform -> Expr CoreBndr +trueValInt platform = Lit $ onei platform -- see Note [What's true and false] +falseValInt platform = Lit $ zeroi platform trueValBool, falseValBool :: Expr CoreBndr trueValBool = Var trueDataConId -- see Note [What's true and false] @@ -1016,12 +1016,12 @@ ltVal = Var ordLTDataConId eqVal = Var ordEQDataConId gtVal = Var ordGTDataConId -mkIntVal :: DynFlags -> Integer -> Expr CoreBndr -mkIntVal dflags i = Lit (mkLitInt dflags i) -mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr -mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) -mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr -mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) +mkIntVal :: Platform -> Integer -> Expr CoreBndr +mkIntVal platform i = Lit (mkLitInt platform i) +mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr +mkFloatVal env f = Lit (convFloating env (LitFloat f)) +mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr +mkDoubleVal env d = Lit (convFloating env (LitDouble d)) matchPrimOpId :: PrimOp -> Id -> RuleM () matchPrimOpId op id = do @@ -1091,7 +1091,7 @@ dataToTagRule = a `mplus` b -- dataToTag x -- where x's unfolding is a constructor application b = do - dflags <- getDynFlags + dflags <- getPlatform [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg @@ -1275,8 +1275,8 @@ builtinRules , do [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just n <- return $ exactLog2 d - dflags <- getDynFlags - return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n + platform <- getPlatform + return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n ], mkBasicRule modIntName 2 $ msum @@ -1285,9 +1285,9 @@ builtinRules , do [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just _ <- return $ exactLog2 d - dflags <- getDynFlags + platform <- getPlatform return $ Var (mkPrimOpId AndIOp) - `App` arg `App` mkIntVal dflags (d - 1) + `App` arg `App` mkIntVal platform (d - 1) ] ] ++ builtinIntegerRules @@ -1609,10 +1609,10 @@ warning in this case. match_bitInteger :: RuleFun -- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer -match_bitInteger dflags id_unf fn [arg] +match_bitInteger env id_unf fn [arg] | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg , x >= 0 - , x <= (wordSizeInBits dflags - 1) + , x <= (toInteger (platformWordSizeInBits (roPlatform env)) - 1) -- Make sure x is small enough to yield a decently small integer -- Attempting to construct the Integer for -- (bitInteger 9223372036854775807#) @@ -1628,11 +1628,11 @@ match_bitInteger _ _ _ _ = Nothing ------------------------------------------------- match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) + => (Platform -> a -> Expr CoreBndr) -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] +match_Integer_convert convert env id_unf _ [xl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) + = Just (convert (roPlatform env) (fromInteger x)) match_Integer_convert _ _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) -> RuleFun @@ -1707,10 +1707,10 @@ match_Integer_shift_op binop _ id_unf _ [xl,yl] match_Integer_shift_op _ _ _ _ _ = Nothing match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun -match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] +match_Integer_binop_Prim binop env id_unf _ [xl, yl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) + = Just (if x `binop` y then trueValInt (roPlatform env) else falseValInt (roPlatform env)) match_Integer_binop_Prim _ _ _ _ _ = Nothing match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun @@ -1753,7 +1753,7 @@ match_rationalTo mkLit _ id_unf _ [xl, yl] match_rationalTo _ _ _ _ _ = Nothing match_decodeDouble :: RuleFun -match_decodeDouble dflags id_unf fn [xl] +match_decodeDouble env id_unf fn [xl] | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, res) @@ -1762,7 +1762,7 @@ match_decodeDouble dflags id_unf fn [xl] (y, z) -> Just $ mkCoreUbxTup [integerTy, intHashTy] [Lit (mkLitInteger y integerTy), - Lit (mkLitInt dflags (toInteger z))] + Lit (mkLitInt (roPlatform env) (toInteger z))] _ -> pprPanic "match_decodeDouble: Id has the wrong type" (ppr fn <+> dcolon <+> ppr (idType fn)) @@ -1880,14 +1880,16 @@ match_smallIntegerTo _ _ _ _ _ = Nothing -- | Rules to perform constant folding into nested expressions -- --See Note [Constant folding through nested expressions] -numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr +numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr numFoldingRules op dict = do - [e1,e2] <- getArgs - dflags <- getDynFlags - let PrimOps{..} = dict dflags - if not (gopt Opt_NumConstantFolding dflags) - then mzero - else case BinOpApp e1 op e2 of + env <- getEnv + if not (roNumConstantFolding env) + then mzero + else do + [e1,e2] <- getArgs + platform <- getPlatform + let PrimOps{..} = dict platform + case BinOpApp e1 op e2 of -- R1) +/- simplification x :++: (y :++: v) -> return $ mkL (x+y) `add` v x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v @@ -2026,7 +2028,7 @@ isMulOp _ = False -- | Explicit "type-class"-like dictionary for numeric primops -- --- Depends on DynFlags because creating a literal value depends on DynFlags +-- Depends on Platform because creating a literal value depends on Platform data PrimOps = PrimOps { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers @@ -2034,20 +2036,20 @@ data PrimOps = PrimOps , mkL :: Integer -> CoreExpr -- ^ Create a literal value } -intPrimOps :: DynFlags -> PrimOps -intPrimOps dflags = PrimOps +intPrimOps :: Platform -> PrimOps +intPrimOps platform = PrimOps { add = \x y -> BinOpApp x IntAddOp y , sub = \x y -> BinOpApp x IntSubOp y , mul = \x y -> BinOpApp x IntMulOp y - , mkL = intResult' dflags + , mkL = intResult' platform } -wordPrimOps :: DynFlags -> PrimOps -wordPrimOps dflags = PrimOps +wordPrimOps :: Platform -> PrimOps +wordPrimOps platform = PrimOps { add = \x y -> BinOpApp x WordAddOp y , sub = \x y -> BinOpApp x WordSubOp y , mul = \x y -> BinOpApp x WordMulOp y - , mkL = wordResult' dflags + , mkL = wordResult' platform } @@ -2059,7 +2061,7 @@ wordPrimOps dflags = PrimOps -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. -caseRules :: DynFlags +caseRules :: Platform -> CoreExpr -- Scrutinee -> Maybe ( CoreExpr -- New scrutinee , AltCon -> Maybe AltCon -- How to fix up the alt pattern @@ -2077,31 +2079,31 @@ caseRules :: DynFlags -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; -- ... } -caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# +caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x# | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicRight op x - = Just (v, tx_lit_con dflags adjust_lit + = Just (v, tx_lit_con platform adjust_lit , \v -> (App (App (Var f) (Var v)) (Lit l))) -caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v +caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v | Just op <- isPrimOpId_maybe f , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicLeft x op - = Just (v, tx_lit_con dflags adjust_lit + = Just (v, tx_lit_con platform adjust_lit , \v -> (App (App (Var f) (Lit l)) (Var v))) -caseRules dflags (App (Var f) v ) -- op v +caseRules platform (App (Var f) v ) -- op v | Just op <- isPrimOpId_maybe f , Just adjust_lit <- adjustUnary op - = Just (v, tx_lit_con dflags adjust_lit + = Just (v, tx_lit_con platform adjust_lit , \v -> App (Var f) (Var v)) -- See Note [caseRules for tagToEnum] -caseRules dflags (App (App (Var f) type_arg) v) +caseRules platform (App (App (Var f) type_arg) v) | Just TagToEnumOp <- isPrimOpId_maybe f - = Just (v, tx_con_tte dflags + = Just (v, tx_con_tte platform , \v -> (App (App (Var f) type_arg) (Var v))) -- See Note [caseRules for dataToTag] @@ -2115,10 +2117,10 @@ caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x caseRules _ _ = Nothing -tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon -tx_lit_con _ _ DEFAULT = Just DEFAULT -tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) -tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) +tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges -- (See Note [Word/Int underflow/overflow] in Literal and #13172). @@ -2157,11 +2159,11 @@ adjustUnary op IntNegOp -> Just (\y -> negate y ) _ -> Nothing -tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon -tx_con_tte _ DEFAULT = Just DEFAULT -tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) -tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] - = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc +tx_con_tte :: Platform -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT +tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) +tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] + = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc tx_con_dtt :: Type -> AltCon -> Maybe AltCon tx_con_dtt _ DEFAULT = Just DEFAULT diff --git a/compiler/GHC/Core/Op/FloatIn.hs b/compiler/GHC/Core/Op/FloatIn.hs index ac4ef8088e..454ce39dfb 100644 --- a/compiler/GHC/Core/Op/FloatIn.hs +++ b/compiler/GHC/Core/Op/FloatIn.hs @@ -21,6 +21,7 @@ module GHC.Core.Op.FloatIn ( floatInwards ) where #include "HsVersions.h" import GhcPrelude +import GHC.Platform import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) @@ -46,12 +47,13 @@ actually float any bindings downwards from the top-level. floatInwards :: ModGuts -> CoreM ModGuts floatInwards pgm@(ModGuts { mg_binds = binds }) = do { dflags <- getDynFlags - ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) } + ; let platform = targetPlatform dflags + ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } where - fi_top_bind dflags (NonRec binder rhs) - = NonRec binder (fiExpr dflags [] (freeVars rhs)) - fi_top_bind dflags (Rec pairs) - = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ] + fi_top_bind platform (NonRec binder rhs) + = NonRec binder (fiExpr platform [] (freeVars rhs)) + fi_top_bind platform (Rec pairs) + = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] {- @@ -137,7 +139,7 @@ data FloatInBind = FB BoundVarSet FreeVarSet FloatBind type FloatInBinds = [FloatInBind] -- In reverse dependency order (innermost binder first) -fiExpr :: DynFlags +fiExpr :: Platform -> FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr @@ -148,12 +150,12 @@ fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr dflags to_drop (_, AnnCast expr (co_ann, co)) +fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr dflags e_drop expr) co + Cast (fiExpr platform e_drop expr) co where [drop_here, e_drop, co_drop] - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False [freeVarsOf expr, freeVarsOfAnn co_ann] to_drop @@ -163,11 +165,11 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. -} -fiExpr dflags to_drop ann_expr@(_,AnnApp {}) +fiExpr platform to_drop ann_expr@(_,AnnApp {}) = wrapFloats drop_here $ wrapFloats extra_drop $ mkTicks ticks $ - mkApps (fiExpr dflags fun_drop ann_fun) - (zipWith (fiExpr dflags) arg_drops ann_args) + mkApps (fiExpr platform fun_drop ann_fun) + (zipWith (fiExpr platform) arg_drops ann_args) where (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr fun_ty = exprType (deAnnotate ann_fun) @@ -175,7 +177,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {}) arg_fvs = map freeVarsOf ann_args (drop_here : extra_drop : fun_drop : arg_drops) - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False (extra_fvs : fun_fvs : arg_fvs) to_drop -- Shortcut behaviour: if to_drop is empty, @@ -306,13 +308,13 @@ be dropped right away. -} -fiExpr dflags to_drop lam@(_, AnnLam _ _) +fiExpr platform to_drop lam@(_, AnnLam _ _) | noFloatIntoLam bndrs -- Dump it all here -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 - = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) | otherwise -- Float inside - = mkLams bndrs (fiExpr dflags to_drop body) + = mkLams bndrs (fiExpr platform to_drop body) where (bndrs, body) = collectAnnBndrs lam @@ -324,12 +326,12 @@ We don't float lets inwards past an SCC. cc, change current cc to the new one and float binds into expr. -} -fiExpr dflags to_drop (_, AnnTick tickish expr) +fiExpr platform to_drop (_, AnnTick tickish expr) | tickish `tickishScopesLike` SoftScope - = Tick tickish (fiExpr dflags to_drop expr) + = Tick tickish (fiExpr platform to_drop expr) | otherwise -- Wimp out for now - we could push values in - = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr)) + = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) {- For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -382,11 +384,11 @@ idRuleAndUnfoldingVars of x. No need for type variables, hence not using idFreeVars. -} -fiExpr dflags to_drop (_,AnnLet bind body) - = fiExpr dflags (after ++ new_float : before) body +fiExpr platform to_drop (_,AnnLet bind body) + = fiExpr platform (after ++ new_float : before) body -- to_drop is in reverse dependency order where - (before, new_float, after) = fiBind dflags to_drop bind body_fvs + (before, new_float, after) = fiBind platform to_drop bind body_fvs body_fvs = freeVarsOf body {- Note [Floating primops] @@ -442,40 +444,40 @@ bindings are: -} -fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnliftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] = wrapFloats shared_binds $ - fiExpr dflags (case_float : rhs_binds) rhs + fiExpr platform (case_float : rhs_binds) rhs where case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr dflags scrut_binds scrut + scrut' = fiExpr platform scrut_binds scrut rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False [scrut_fvs, rhs_fvs] to_drop -fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) +fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ wrapFloats drop_here2 $ - Case (fiExpr dflags scrut_drops scrut) case_bndr ty + Case (fiExpr platform scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False [scrut_fvs, all_alts_fvs] to_drop -- Float into the alts with the is_case flag set (drop_here2 : alts_drops_s) | [ _ ] <- alts = [] : [alts_drops] - | otherwise = sepBindsByDropPoint dflags True alts_fvs alts_drops + | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts @@ -485,10 +487,10 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs) + fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs) ------------------ -fiBind :: DynFlags +fiBind :: Platform -> FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreBindWithFVs -- Input binding @@ -497,7 +499,7 @@ fiBind :: DynFlags , FloatInBind -- The binding itself , FloatInBinds) -- Land these after -fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs +fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs = ( extra_binds ++ shared_binds -- Land these before -- See Note [extra_fvs (1,2)] , FB (unitDVarSet id) rhs_fvs' -- The new binding itself @@ -518,16 +520,16 @@ fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs -- But do float into join points [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False [extra_fvs, rhs_fvs, body_fvs2] to_drop -- Push rhs_binds into the right hand side of the binding - rhs' = fiRhs dflags rhs_binds id ann_rhs + rhs' = fiRhs platform rhs_binds id ann_rhs rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs -- Don't forget the rule_fvs; the binding mentions them! -fiBind dflags to_drop (AnnRec bindings) body_fvs +fiBind platform to_drop (AnnRec bindings) body_fvs = ( extra_binds ++ shared_binds , FB (mkDVarSet ids) rhs_fvs' (FloatLet (Rec (fi_bind rhss_binds bindings))) @@ -543,7 +545,7 @@ fiBind dflags to_drop (AnnRec bindings) body_fvs , noFloatIntoRhs Recursive bndr rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint dflags False + = sepBindsByDropPoint platform False (extra_fvs:body_fvs:rhss_fvs) to_drop @@ -557,17 +559,17 @@ fiBind dflags to_drop (AnnRec bindings) body_fvs -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiRhs dflags to_drop binder rhs) + = [ (binder, fiRhs platform to_drop binder rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] ------------------ -fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr -fiRhs dflags to_drop bndr rhs +fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs platform to_drop bndr rhs | Just join_arity <- isJoinId_maybe bndr , let (bndrs, body) = collectNAnnBndrs join_arity rhs - = mkLams bndrs (fiExpr dflags to_drop body) + = mkLams bndrs (fiExpr platform to_drop body) | otherwise - = fiExpr dflags to_drop rhs + = fiExpr platform to_drop rhs ------------------ noFloatIntoLam :: [Var] -> Bool @@ -665,7 +667,7 @@ We have to maintain the order on these drop-point-related lists. -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] sepBindsByDropPoint - :: DynFlags + :: Platform -> Bool -- True <=> is case expression -> [FreeVarSet] -- One set of FVs per drop point -- Always at least two long! @@ -682,7 +684,7 @@ sepBindsByDropPoint type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint dflags is_case drop_pts floaters +sepBindsByDropPoint platform is_case drop_pts floaters | null floaters -- Shortcut common case = [] : [[] | _ <- drop_pts] @@ -714,7 +716,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters cant_push | is_case = n_used_alts == n_alts -- Used in all, don't push -- Remember n_alts > 1 - || (n_used_alts > 1 && not (floatIsDupable dflags bind)) + || (n_used_alts > 1 && not (floatIsDupable platform bind)) -- floatIsDupable: see Note [Duplicating floats] | otherwise = floatIsCase bind || n_used_alts > 1 @@ -762,10 +764,10 @@ wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr wrapFloats [] e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) -floatIsDupable :: DynFlags -> FloatBind -> Bool -floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut -floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs -floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r +floatIsDupable :: Platform -> FloatBind -> Bool +floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut +floatIsDupable platform (FloatLet (Rec prs)) = all (exprIsDupable platform . snd) prs +floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r floatIsCase :: FloatBind -> Bool floatIsCase (FloatCase {}) = True diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs index 448edd21f6..760beeddb2 100644 --- a/compiler/GHC/Core/Op/Simplify.hs +++ b/compiler/GHC/Core/Op/Simplify.hs @@ -13,6 +13,7 @@ module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where import GhcPrelude +import GHC.Platform import GHC.Driver.Session import GHC.Core.Op.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) @@ -3092,7 +3093,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs res_ty = contResultType cont ; (floats2, body2) - <- if exprIsDupable (seDynFlags env) join_body + <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body then return (emptyFloats env, join_body) else do { join_bndr <- newJoinId [bndr'] res_ty ; let join_call = App (Var join_bndr) (Var bndr') @@ -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 -- 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' ; let all_floats = floats `addJoinFloats` join_floats @@ -3188,11 +3189,11 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils , sc_cont = mkBoringStop (contResultType cont) } ) } -mkDupableAlt :: DynFlags -> OutId +mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs') - | exprIsDupable dflags rhs' -- Note [Small alternative rhs] +mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs') + | exprIsDupable platform rhs' -- Note [Small alternative rhs] = return (jfloats, (con, bndrs', rhs')) | otherwise diff --git a/compiler/GHC/Core/Op/Simplify/Utils.hs b/compiler/GHC/Core/Op/Simplify/Utils.hs index e62c256354..5fb9ddcee4 100644 --- a/compiler/GHC/Core/Op/Simplify/Utils.hs +++ b/compiler/GHC/Core/Op/Simplify/Utils.hs @@ -2152,7 +2152,7 @@ mkCase2 dflags scrut bndr alts_ty alts [(DEFAULT,_,_)] -> False _ -> True , 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') ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index bb58d25927..30b652655d 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -58,7 +58,7 @@ import NameEnv import UniqFM import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import BasicTypes -import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.Session hiding (ruleCheck) import Outputable import FastString import Maybes @@ -510,7 +510,12 @@ matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) matchRule dflags rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) -- 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 Just expr -> Just expr diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 6ee5b27963..e99f840bb9 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -7,6 +7,7 @@ The @TyCon@ datatype -} {-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} module GHC.Core.TyCon( -- * Main TyCon data types @@ -134,6 +135,7 @@ module GHC.Core.TyCon( #include "HsVersions.h" import GhcPrelude +import GHC.Platform import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Kind, Type, PredType, mkForAllTy, mkFunTy ) @@ -152,7 +154,6 @@ import Var import VarSet import GHC.Core.Class import BasicTypes -import GHC.Driver.Session import ForeignCall import Name import NameEnv @@ -1474,20 +1475,20 @@ isGcPtrRep _ = False -- 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. -primRepCompatible :: DynFlags -> PrimRep -> PrimRep -> Bool -primRepCompatible dflags rep1 rep2 = +primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = (isUnboxed rep1 == isUnboxed rep2) && - (primRepSizeB dflags rep1 == primRepSizeB dflags rep2) && + (primRepSizeB platform rep1 == primRepSizeB platform rep2) && (primRepIsFloat rep1 == primRepIsFloat rep2) where isUnboxed = not . isGcPtrRep -- More general version of `primRepCompatible` for types represented by zero or -- more than one PrimReps. -primRepsCompatible :: DynFlags -> [PrimRep] -> [PrimRep] -> Bool -primRepsCompatible dflags reps1 reps2 = +primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = length reps1 == length reps2 && - and (zipWith (primRepCompatible dflags) reps1 reps2) + and (zipWith (primRepCompatible platform) reps1 reps2) -- | The size of a 'PrimRep' in bytes. -- @@ -1496,24 +1497,25 @@ primRepsCompatible dflags reps1 reps2 = -- 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 -- laid out. -primRepSizeB :: DynFlags -> PrimRep -> Int -primRepSizeB dflags IntRep = wORD_SIZE dflags -primRepSizeB dflags WordRep = wORD_SIZE dflags -primRepSizeB _ Int8Rep = 1 -primRepSizeB _ Int16Rep = 2 -primRepSizeB _ Int32Rep = 4 -primRepSizeB _ Int64Rep = wORD64_SIZE -primRepSizeB _ Word8Rep = 1 -primRepSizeB _ Word16Rep = 2 -primRepSizeB _ Word32Rep = 4 -primRepSizeB _ Word64Rep = wORD64_SIZE -primRepSizeB _ FloatRep = fLOAT_SIZE -primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags -primRepSizeB dflags AddrRep = wORD_SIZE dflags -primRepSizeB dflags LiftedRep = wORD_SIZE dflags -primRepSizeB dflags UnliftedRep = wORD_SIZE dflags -primRepSizeB _ VoidRep = 0 -primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep +primRepSizeB :: Platform -> PrimRep -> Int +primRepSizeB platform = \case + IntRep -> platformWordSizeInBytes platform + WordRep -> platformWordSizeInBytes platform + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> wORD64_SIZE + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> wORD64_SIZE + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> platformWordSizeInBytes platform + LiftedRep -> platformWordSizeInBytes platform + UnliftedRep -> platformWordSizeInBytes platform + VoidRep -> 0 + (VecRep len rep) -> len * primElemRepSizeB rep primElemRepSizeB :: PrimElemRep -> Int primElemRepSizeB Int8ElemRep = 1 diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index fb22885f47..e10029c988 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -63,6 +63,7 @@ module GHC.Core.Utils ( #include "HsVersions.h" import GhcPrelude +import GHC.Platform import GHC.Core import PrelNames ( makeStaticName ) @@ -87,7 +88,6 @@ import GHC.Core.TyCon import Unique import Outputable import TysPrim -import GHC.Driver.Session import FastString import Maybes import ListSetOps ( minusList ) @@ -1138,8 +1138,8 @@ Note [exprIsDupable] and then inlining of case join points -} -exprIsDupable :: DynFlags -> CoreExpr -> Bool -exprIsDupable dflags e +exprIsDupable :: Platform -> CoreExpr -> Bool +exprIsDupable platform e = isJust (go dupAppSize e) where go :: Int -> CoreExpr -> Maybe Int @@ -1149,7 +1149,7 @@ exprIsDupable dflags e go n (Tick _ 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 (Lit lit) | litIsDupable dflags lit = decrement n + go n (Lit lit) | litIsDupable platform lit = decrement n go _ _ = Nothing decrement :: Int -> Maybe Int diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 1cac00320f..f16d77f782 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -296,11 +296,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis peep [] = [] -argBits :: DynFlags -> [ArgRep] -> [Bool] -argBits _ [] = [] -argBits dflags (rep : args) - | isFollowableArg rep = False : argBits dflags args - | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args +argBits :: Platform -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits platform (rep : args) + | isFollowableArg rep = False : argBits platform args + | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -390,12 +390,12 @@ schemeR_wrk fvs nm original_body (args, body) -- Stack arguments always take a whole number of words, we never pack -- 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 p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- 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 = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -518,8 +518,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) -- saturated constructor application. -- Just allocate the constructor and carry on alloc_code <- mkConAppCode d s p data_con args_r_to_l - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- targetPlatform <$> getDynFlags let !d2 = d + wordSize platform body_code <- schemeE d2 s (Map.insert x d2 p) body return (alloc_code `appOL` body_code) @@ -527,10 +526,9 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) -- General case for let. Generates correct, if inefficient, code in -- all situations. schemeE d s p (AnnLet binds (_,body)) = do - dflags <- getDynFlags + platform <- targetPlatform <$> getDynFlags let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) AnnRec xs_n_rhss -> unzip xs_n_rhss - platform = targetPlatform dflags n_binds = genericLength xs fvss = map (fvsToEnv p' . fst) rhss @@ -539,7 +537,7 @@ schemeE d s p (AnnLet binds (_,body)) = do (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss -- 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 -- the arity of each rhs @@ -1029,7 +1027,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- depth of stack after the return value has been pushed 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 -- 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 code_n_reps <- pargs d0 args_r_to_l let (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 !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 -- Push the return placeholder. For a call returning nothing, -- 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 push_r = if returns_void 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 @@ -1394,11 +1392,11 @@ primRepToFFIType platform r -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: DynFlags -> PrimRep -> Literal -mkDummyLiteral dflags pr +mkDummyLiteral :: Platform -> PrimRep -> Literal +mkDummyLiteral platform pr = case pr of - IntRep -> mkLitInt dflags 0 - WordRep -> mkLitWord dflags 0 + IntRep -> mkLitInt platform 0 + WordRep -> mkLitWord platform 0 Int64Rep -> mkLitInt64 0 Word64Rep -> mkLitWord64 0 AddrRep -> LitNullAddr @@ -1575,15 +1573,13 @@ pushAtom d p (AnnVar var) | Just primop <- isPrimOpId_maybe var = do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- targetPlatform <$> getDynFlags return (unitOL (PUSH_PRIMOP primop), wordSize platform) | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable - = do dflags <- getDynFlags - let platform = targetPlatform dflags + = do platform <- targetPlatform <$> getDynFlags - let !szb = idSizeCon dflags var + let !szb = idSizeCon platform var with_instr instr = do let !off_b = trunc16B $ d - d_v return (unitOL (instr off_b), wordSize platform) @@ -1605,22 +1601,20 @@ pushAtom d p (AnnVar var) | otherwise -- var must be a global variable = do topStrings <- getTopStrings - dflags <- getDynFlags + platform <- targetPlatform <$> getDynFlags 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 Nothing -> do - let sz = idSizeCon dflags var - let platform = targetPlatform dflags + let sz = idSizeCon platform var MASSERT( sz == wordSize platform ) return (unitOL (PUSH_G (getName var)), sz) pushAtom _ _ (AnnLit lit) = do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- targetPlatform <$> getDynFlags 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)), wordsToBytes platform size_words) @@ -1659,8 +1653,8 @@ pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = pushConstrAtom d p (AnnVar v) | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable - dflags <- getDynFlags - let !szb = idSizeCon dflags v + platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform v done instr = do let !off = trunc16B $ d - d_v return (unitOL (instr off), szb) @@ -1824,11 +1818,11 @@ instance Outputable Discr where lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup -idSizeW :: DynFlags -> Id -> WordOff -idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep +idSizeW :: Platform -> Id -> WordOff +idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep -idSizeCon :: DynFlags -> Id -> ByteOff -idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep +idSizeCon :: Platform -> Id -> ByteOff +idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep bcIdArgRep :: Id -> ArgRep bcIdArgRep = toArgRep . bcIdPrimRep @@ -1840,8 +1834,8 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -repSizeWords :: DynFlags -> PrimRep -> WordOff -repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep) +repSizeWords :: Platform -> PrimRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 786792ea0f..a866f57b6b 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -608,11 +608,11 @@ coreToStgArgs (arg : args) = do -- Non-type argument -- or foreign call. -- Wanted: a better solution than this hacky warning - dflags <- getDynFlags + platform <- targetPlatform <$> getDynFlags let arg_rep = typePrimRep (exprType 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 ) return (stg_arg : stg_args, ticks ++ aticks) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 39f137d657..fb46438049 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -18,6 +18,7 @@ module GHC.CoreToStg.Prep ( #include "HsVersions.h" import GhcPrelude +import GHC.Platform import GHC.Core.Op.OccurAnal @@ -574,10 +575,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) 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) 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) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr @@ -652,17 +653,17 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 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 -- representation. Exactly how we do this depends on the -- library that implements Integer. If it's GMP we -- use the S# data constructor for small literals. -- See Note [Integer literals] in Literal -cvtLitInteger dflags _ (Just sdatacon) i - | inIntRange dflags i -- Special case for small integers - = mkConApp sdatacon [Lit (mkLitInt dflags i)] +cvtLitInteger platform _ (Just sdatacon) i + | platformInIntRange platform i -- Special case for small integers + = mkConApp sdatacon [Lit (mkLitInt platform i)] -cvtLitInteger dflags mk_integer _ i +cvtLitInteger platform mk_integer _ i = mkApps (Var mk_integer) [isNonNegative, ints] where isNonNegative = if i < 0 then mkConApp falseDataCon [] else mkConApp trueDataCon [] @@ -670,25 +671,25 @@ cvtLitInteger dflags mk_integer _ i f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high + in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high bits = 31 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 -- representation. -- See Note [Natural literals] in Literal -cvtLitNatural dflags _ (Just sdatacon) i - | inWordRange dflags i -- Special case for small naturals - = mkConApp sdatacon [Lit (mkLitWord dflags i)] +cvtLitNatural platform _ (Just sdatacon) i + | platformInWordRange platform i -- Special case for small naturals + = mkConApp sdatacon [Lit (mkLitWord platform i)] -cvtLitNatural dflags mk_natural _ i +cvtLitNatural platform mk_natural _ i = mkApps (Var mk_natural) [words] where words = mkListExpr wordTy (f i) f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high + in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high bits = 32 mask = 2 ^ bits - 1 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index cf9b84dcf4..d511701ea1 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -203,7 +203,6 @@ module GHC.Driver.Session ( wordAlignment, tAG_MASK, mAX_PTR_TAG, - tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, @@ -292,13 +291,11 @@ import Control.Monad.Trans.Except import Data.Ord import Data.Bits import Data.Char -import Data.Int import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Word import System.FilePath import System.Directory import System.Environment (lookupEnv) @@ -4915,10 +4912,11 @@ compilerInfo dflags #include "GHCConstantsHaskellWrappers.hs" 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 dflags = alignmentOf (wORD_SIZE dflags) +wordAlignment :: Platform -> Alignment +wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) tAG_MASK :: DynFlags -> Int tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 @@ -4926,22 +4924,6 @@ tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 mAX_PTR_TAG :: DynFlags -> Int 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 1a52bcc966..147da687d0 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -488,6 +488,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do makeStaticId <- dsLookupGlobalId makeStaticName dflags <- getDynFlags + let platform = targetPlatform dflags let (line, col) = case loc of RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r @@ -496,7 +497,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do _ -> (0, 0) srcLoc = mkCoreConApps (tupleDataCon Boxed 2) [ Type intTy , Type intTy - , mkIntExprInt dflags line, mkIntExprInt dflags col + , mkIntExprInt platform line, mkIntExprInt platform col ] putSrcSpanDs loc $ return $ @@ -890,7 +891,8 @@ dsExplicitList elt_ty Nothing xs dsExplicitList elt_ty (Just fln) xs = do { list <- dsExplicitList elt_ty Nothing xs ; 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 expr (From from) diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 705101caf3..2abce51649 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -23,6 +23,7 @@ where import GhcPrelude +import GHC.Platform import GHC.Core @@ -152,9 +153,10 @@ unboxArg arg | Just tc <- tyConAppTyCon_maybe arg_ty, tc `hasKey` boolTyConKey = do dflags <- getDynFlags + let platform = targetPlatform dflags prim_arg <- newSysLocalDs intPrimTy return (Var prim_arg, - \ body -> Case (mkIfThenElse arg (mkIntLit dflags 1) (mkIntLit dflags 0)) + \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg (exprType body) [(DEFAULT,[],body)]) @@ -326,10 +328,11 @@ resultWrapper result_ty | Just (tc,_) <- maybe_tc_app , tc `hasKey` boolTyConKey = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags ; let marshal_bool e = mkWildCase e intPrimTy boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)] + [ (DEFAULT ,[],Var trueDataConId ) + , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } -- Newtypes @@ -349,8 +352,9 @@ resultWrapper result_ty , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty - ; let narrow_wrapper = maybeNarrow dflags tycon + ; let narrow_wrapper = maybeNarrow platform tycon marshal_con e = Var (dataConWrapId data_con) `mkTyApps` tycon_arg_tys `App` wrapper (narrow_wrapper e) @@ -366,15 +370,17 @@ resultWrapper result_ty -- standard appears to say that this is the responsibility of the -- caller, not the callee. -maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow dflags tycon +maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow platform tycon | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e | tycon `hasKey` int32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + , platformWordSizeInBytes platform > 4 + = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e | tycon `hasKey` word32TyConKey - && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + , platformWordSizeInBytes platform > 4 + = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e | otherwise = id diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 0e19c375c6..222bcc042d 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -423,6 +423,7 @@ dsFExportDynamic :: Id dsFExportDynamic id co0 cconv = do mod <- getModule dflags <- getDynFlags + let platform = targetPlatform dflags let fe_nm = mkFastString $ zEncodeString (moduleStableString mod ++ "$" ++ toCName dflags id) -- Construct the label based on the passed id, don't use names @@ -444,7 +445,7 @@ dsFExportDynamic id co0 cconv = do to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) + adj_args = [ mkIntLitInt platform (ccallConvToInt cconv) , Var stbl_value , Lit (LitLabel fe_nm mb_sz_args IsFunction) , Lit (mkLitString typestring) @@ -549,10 +550,10 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc type_string -- libffi needs to know the result type too: - | libffi = primTyDescChar dflags res_hty : arg_type_string + | libffi = primTyDescChar platform res_hty : arg_type_string | otherwise = arg_type_string - arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] -- just the real args -- add some auxiliary args; the stable ptr in the wrapper case, and @@ -802,8 +803,8 @@ getPrimTyOf ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, -- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: DynFlags -> Type -> Char -primTyDescChar dflags ty +primTyDescChar :: Platform -> Type -> Char +primTyDescChar platform ty | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep1 (getPrimTyOf ty) of @@ -816,7 +817,6 @@ primTyDescChar dflags ty DoubleRep -> 'd' _ -> pprPanic "primTyDescChar" (ppr ty) where - (signed_word, unsigned_word) - | wORD_SIZE dflags == 4 = ('W','w') - | wORD_SIZE dflags == 8 = ('L','l') - | otherwise = panic "primTyDescChar" + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> ('W','w') + PW8 -> ('L','l') diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 48cfe6fa7a..657946ffcb 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -24,6 +24,7 @@ where #include "HsVersions.h" import GhcPrelude +import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) @@ -186,11 +187,12 @@ match [] ty eqns match (v:vs) ty eqns -- Eqns *can* be empty = ASSERT2( all (isInternalName . idName) vars, ppr vars ) do { dflags <- getDynFlags + ; let platform = targetPlatform dflags -- Tidy the first pattern, generating -- auxiliary bindings if necessary ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; let grouped = groupEquations dflags tidy_eqns + ; let grouped = groupEquations platform tidy_eqns -- print the view patterns that are commoned up to help debug ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) @@ -910,13 +912,13 @@ the PgN constructor as a Rational if numeric, and add a PgOverStr constructor for overloaded strings. -} -groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] +groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged -groupEquations dflags eqns - = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns] +groupEquations platform eqns + = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns] -- comprehension on NonEmpty where same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool @@ -1117,7 +1119,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list _ (_:_) [] = False eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys -patGroup :: DynFlags -> Pat GhcTc -> PatGroup +patGroup :: Platform -> Pat GhcTc -> PatGroup patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon @@ -1140,7 +1142,7 @@ patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList -patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) +patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) {- diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 090227bf32..5a5ef53655 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -24,6 +24,7 @@ where #include "HsVersions.h" import GhcPrelude +import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr ) @@ -88,19 +89,20 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. dsLit :: HsLit GhcRn -> DsM CoreExpr dsLit l = do dflags <- getDynFlags + let platform = targetPlatform dflags case l of HsStringPrim _ s -> return (Lit (LitString s)) HsCharPrim _ c -> return (Lit (LitChar c)) - HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) - HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) - HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) - HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) + HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) + HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap platform i)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w)) HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str HsInteger _ i _ -> mkIntegerExpr i - HsInt _ i -> return (mkIntExpr dflags (il_value i)) + HsInt _ i -> return (mkIntExpr platform (il_value i)) XLit nec -> noExtCon nec HsRat _ (FL _ _ val) ty -> do num <- mkIntegerExpr (numerator val) @@ -119,7 +121,8 @@ dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty , ol_witness = witness }) = do dflags <- getDynFlags - case shortCutLit dflags val ty of + let platform = targetPlatform dflags + case shortCutLit platform val ty of Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] _ -> dsExpr witness dsOverLit (XOverLit nec) = noExtCon nec @@ -426,9 +429,10 @@ matchLiterals (var :| vars) ty sub_groups match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult) match_group eqns@(firstEqn :| _) = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags ; let LitPat _ hs_lit = firstPat firstEqn ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) - ; return (hsLitKey dflags hs_lit, match_result) } + ; return (hsLitKey platform hs_lit, match_result) } wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals @@ -443,7 +447,7 @@ matchLiterals (var :| vars) ty sub_groups --------------------------- -hsLitKey :: DynFlags -> HsLit GhcTc -> Literal +hsLitKey :: Platform -> HsLit GhcTc -> Literal -- Get the Core literal corresponding to a HsLit. -- It only works for primitive types and strings; -- others have been removed by tidy @@ -453,15 +457,15 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal -- In the case of the fixed-width numeric types, we need to wrap here -- because Literal has an invariant that the literal is in range, while -- HsLit does not. -hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i -hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w -hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i -hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w -hsLitKey _ (HsCharPrim _ c) = mkLitChar c -hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) -hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) -hsLitKey _ (HsString _ s) = LitString (bytesFS s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) +hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i +hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey platform (HsInt64Prim _ i) = mkLitInt64Wrap platform i +hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) +hsLitKey _ (HsString _ s) = LitString (bytesFS s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 61278391d0..ee1c0d8062 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -514,10 +514,11 @@ translatePat fam_insts x pat = case pat of -- type of the scrutinee, so info on both pattern and scrutinee (for which -- short cutting in dsOverLit works properly) is overloaded iff either is. dflags <- getDynFlags + let platform = targetPlatform dflags core_expr <- case olit of OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ } | not rebindable - , Just expr <- shortCutLit dflags val ty + , Just expr <- shortCutLit platform val ty -> dsExpr expr _ -> dsOverLit olit let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr) diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 4ae93bcee8..06ea9e307f 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -27,6 +27,7 @@ module GHC.HsToCore.Quote( dsBracket ) where #include "HsVersions.h" import GhcPrelude +import GHC.Platform import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) @@ -138,6 +139,9 @@ wrapName n = do -- wrapper type MetaM a = ReaderT MetaWrappers DsM a +getPlatform :: MetaM Platform +getPlatform = targetPlatform <$> getDynFlags + ----------------------------------------------------------------------------- dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr -> HsBracket GhcRn @@ -2212,10 +2216,10 @@ repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here repPunboxedSum (MkC p) alt arity - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; rep2 unboxedSumPName [ p - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] @@ -2282,10 +2286,10 @@ repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here repUnboxedSum (MkC e) alt arity - = do { dflags <- getDynFlags + = do { platform <- getPlatform ; rep2 unboxedSumEName [ e - , mkIntExprInt dflags alt - , mkIntExprInt dflags arity ] } + , mkIntExprInt platform alt + , mkIntExprInt platform arity ] } repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] @@ -2689,18 +2693,18 @@ repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = do dflags <- getDynFlags - rep2 tupleTName [mkIntExprInt dflags i] +repTupleTyCon i = do platform <- getPlatform + rep2 tupleTName [mkIntExprInt platform i] repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -- Note: not Core Int; it's easier to be direct here -repUnboxedTupleTyCon i = do dflags <- getDynFlags - rep2 unboxedTupleTName [mkIntExprInt dflags i] +repUnboxedTupleTyCon i = do platform <- getPlatform + rep2 unboxedTupleTName [mkIntExprInt platform i] repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) -- Note: not Core TH.SumArity; it's easier to be direct here -repUnboxedSumTyCon arity = do dflags <- getDynFlags - rep2 unboxedSumTName [mkIntExprInt dflags arity] +repUnboxedSumTyCon arity = do platform <- getPlatform + rep2 unboxedSumTName [mkIntExprInt platform arity] repArrowTyCon :: MetaM (Core (M TH.Type)) repArrowTyCon = rep2 arrowTName [] @@ -2712,8 +2716,8 @@ repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type)) repPromotedDataCon (MkC s) = rep2 promotedTName [s] repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -repPromotedTupleTyCon i = do dflags <- getDynFlags - rep2 promotedTupleTName [mkIntExprInt dflags i] +repPromotedTupleTyCon i = do platform <- getPlatform + rep2 promotedTupleTName [mkIntExprInt platform i] repPromotedNilTyCon :: MetaM (Core (M TH.Type)) repPromotedNilTyCon = rep2 promotedNilTName [] @@ -2746,11 +2750,11 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs) - = do dflags <- getDynFlags + = do platform <- getPlatform word8_ty <- lookupType word8TyConName let w8s = unpack bs w8s_expr = map (\w8 -> mkCoreConApps word8DataCon - [mkWordLit dflags (toInteger w8)]) w8s + [mkWordLit platform (toInteger w8)]) w8s rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit = do lit' <- case lit of @@ -2935,8 +2939,8 @@ coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty) ------------ Literals & Variables ------------------- coreIntLit :: Int -> MetaM (Core Int) -coreIntLit i = do dflags <- getDynFlags - return (MkC (mkIntExprInt dflags i)) +coreIntLit i = do platform <- getPlatform + return (MkC (mkIntExprInt platform i)) coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) coreIntegerLit i = fmap MkC (mkIntegerExpr i) diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index c5850f1eaf..c4ddfa2ece 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -133,9 +133,9 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do -- should be). Also, the serialisation of value of type "Bin -- a" used to depend on the word size of the machine, now they -- are always 32 bits. - if wORD_SIZE dflags == 4 - then do _ <- Binary.get bh :: IO Word32; return () - else do _ <- Binary.get bh :: IO Word64; return () + case platformWordSize (targetPlatform dflags) of + PW4 -> do _ <- Binary.get bh :: IO Word32; return () + PW8 -> do _ <- Binary.get bh :: IO Word64; return () -- Check the interface file version and ways. check_ver <- get bh @@ -191,9 +191,9 @@ writeBinIface dflags hi_path mod_iface = do -- dummy 32/64-bit field before the version/way for -- compatibility with older interface file formats. -- See Note [dummy iface field] above. - if wORD_SIZE dflags == 4 - then Binary.put_ bh (0 :: Word32) - else Binary.put_ bh (0 :: Word64) + case platformWordSize (targetPlatform dflags) of + PW4 -> Binary.put_ bh (0 :: Word32) + PW8 -> Binary.put_ bh (0 :: Word64) -- The version and way descriptor go next put_ bh (show hiVersion) diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 0daea2181b..37d9af0d8b 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -26,6 +26,7 @@ module GHC.Runtime.Heap.Inspect( #include "HsVersions.h" import GhcPrelude +import GHC.Platform import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes @@ -380,7 +381,7 @@ cPprTermBase y = alloca $ \p -> poke p w >> peek (castPtr p) return (Just (Ppr.double f)) -- let's assume that if we get two words, we're on a 32-bit - -- machine. There's no good way to get a DynFlags to check the word + -- machine. There's no good way to get a Platform to check the word -- size here. ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do let f = unsafeDupablePerformIO $ @@ -865,9 +866,10 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 -- within a single word. See also -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding dflags <- getDynFlags - let word_size = wORD_SIZE dflags + let platform = targetPlatform dflags + word_size = platformWordSizeInBytes platform big_endian = wORDS_BIGENDIAN dflags - size_b = primRepSizeB dflags rep + size_b = primRepSizeB platform rep -- Align the start offset (eg, 2-byte value should be 2-byte -- aligned). But not more than to a word. The offset calculation -- should be the same with the offset calculation in diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index b85c460f10..cc477e0eaa 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -21,6 +21,7 @@ module GHC.Stg.Lift.Analysis ( ) where import GhcPrelude +import GHC.Platform import BasicTypes import Demand @@ -374,6 +375,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide , ("args spill on stack", args_spill_on_stack) , ("increases allocation", inc_allocs) ] where + platform = targetPlatform dflags decide deciders | not (fancy_or deciders) = llTrace "stgLiftLams:lifting" @@ -475,7 +477,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide . expander . flip dVarSetMinusVarSet bndrs_set $ freeVarsOfRhs rhs - clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope + clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope rhsLambdaBndrs :: LlStgRhs -> [Id] rhsLambdaBndrs StgRhsCon{} = [] @@ -499,9 +501,9 @@ closureSize dflags ids = words + sTD_HDR_SIZE dflags -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case -- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. -idClosureFootprint:: DynFlags -> Id -> WordOff -idClosureFootprint dflags - = StgToCmm.ArgRep.argRepSizeW dflags +idClosureFootprint:: Platform -> Id -> WordOff +idClosureFootprint platform + = StgToCmm.ArgRep.argRepSizeW platform . StgToCmm.ArgRep.idArgRep -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index 26532b974d..2839a2ff56 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} + module GHC.StgToCmm.ArgRep ( ArgRep(..), toArgRep, argRepSizeW, @@ -16,6 +18,7 @@ module GHC.StgToCmm.ArgRep ( ) where import GhcPrelude +import GHC.Platform import GHC.StgToCmm.Closure ( idPrimRep ) @@ -23,8 +26,7 @@ import GHC.Runtime.Heap.Layout ( WordOff ) import Id ( Id ) import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) import BasicTypes ( RepArity ) -import Constants ( wORD64_SIZE ) -import GHC.Driver.Session +import Constants ( wORD64_SIZE, dOUBLE_SIZE ) import Outputable import FastString @@ -91,16 +93,19 @@ isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True -argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words -argRepSizeW _ N = 1 -argRepSizeW _ P = 1 -argRepSizeW _ F = 1 -argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags -argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -argRepSizeW _ V = 0 -argRepSizeW dflags V16 = 16 `quot` wORD_SIZE dflags -argRepSizeW dflags V32 = 32 `quot` wORD_SIZE dflags -argRepSizeW dflags V64 = 64 `quot` wORD_SIZE dflags +argRepSizeW :: Platform -> ArgRep -> WordOff -- Size in words +argRepSizeW platform = \case + N -> 1 + P -> 1 + F -> 1 + L -> wORD64_SIZE `quot` ws + D -> dOUBLE_SIZE `quot` ws + V -> 0 + V16 -> 16 `quot` ws + V32 -> 32 `quot` ws + V64 -> 64 `quot` ws + where + ws = platformWordSizeInBytes platform idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index d1353fbecb..d60e2805d4 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -14,6 +14,7 @@ module GHC.StgToCmm.Bind ( ) where import GhcPrelude hiding ((<*>)) +import GHC.Platform import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad @@ -69,9 +70,10 @@ cgTopRhsClosure :: DynFlags -> (CgIdInfo, FCode ()) cgTopRhsClosure dflags rec id ccs upd_flag args body = - let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + let platform = targetPlatform dflags + closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC @@ -323,10 +325,11 @@ mkRhsClosure dflags bndr _cc ---------- Default case ------------------ mkRhsClosure dflags bndr cc fvs upd_flag args body - = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args + = do { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where + platform = targetPlatform dflags gen_code lf_info reg = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store @@ -340,7 +343,6 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName - ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] @@ -412,18 +414,18 @@ cgRhsStdThunk bndr lf_info payload ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: DynFlags +mkClosureLFInfo :: Platform -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args -> LambdaFormInfo -mkClosureLFInfo dflags bndr top fvs upd_flag args +mkClosureLFInfo platform bndr top fvs upd_flag args | null args = mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag | otherwise = - mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args) + mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args) ------------------------------------------------------------------------ diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 9983a58616..f896b4d598 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -365,9 +365,8 @@ assignment. cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts | isUnliftedType (idType v) -- Note [Dodgy unsafeCoerce 1] = -- assignment suffices for unlifted types - do { dflags <- getDynFlags - ; platform <- getPlatform - ; unless (reps_compatible dflags) $ + do { platform <- getPlatform + ; unless (reps_compatible platform) $ pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" (pp_bndr v $$ pp_bndr bndr) ; v_info <- getCgIdInfo v @@ -377,7 +376,7 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 21388d81cb..740103e3b1 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -144,7 +144,8 @@ allocHeapClosure rep info_ptr use_cc payload = do emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs = do dflags <- getDynFlags - hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..]) + let platform = targetPlatform dflags + hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..]) where header :: DynFlags -> [CmmExpr] header dflags = [info_ptr] ++ dynProfHdr dflags ccs diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 93aeabb8a9..08e83b84d3 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -463,7 +463,7 @@ mkVirtHeapOffsetsWithPadding dflags header things = (rep, thing) = fromNonVoid nv_thing -- Size of the field in bytes. - !sizeB = primRepSizeB dflags rep + !sizeB = primRepSizeB platform rep -- Align the start offset (eg, 2-byte value should be 2-byte aligned). -- But not more than to a word. @@ -532,20 +532,20 @@ mkVirtConstrSizes dflags field_reps -- bring in ARG_P, ARG_N, etc. #include "../includes/rts/storage/FunTypes.h" -mkArgDescr :: DynFlags -> [Id] -> ArgDescr -mkArgDescr dflags args - = let arg_bits = argBits dflags arg_reps +mkArgDescr :: Platform -> [Id] -> ArgDescr +mkArgDescr platform args + = let arg_bits = argBits platform arg_reps arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns in case stdPattern arg_reps of Just spec_id -> ArgSpec spec_id Nothing -> ArgGen arg_bits -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits _ [] = [] -argBits dflags (P : args) = False : argBits dflags args -argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) - ++ argBits dflags args +argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits platform (P : args) = False : argBits platform args +argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True) + ++ argBits platform args ---------------------- stdPattern :: [ArgRep] -> Maybe Int diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index de3adc7697..5b43837417 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -2469,7 +2469,7 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr emitCopyByteArray copy src src_off dst dst_off n = do dflags <- getDynFlags platform <- getPlatform - let byteArrayAlignment = wordAlignment dflags + let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] @@ -2519,7 +2519,7 @@ doSetByteArrayOp ba off len c = do dflags <- getDynFlags platform <- getPlatform - let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap + let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment @@ -2587,10 +2587,9 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - platform <- getPlatform + do platform <- getPlatform emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags) + (wordAlignment platform) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -2605,13 +2604,12 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do - dflags <- getDynFlags platform <- getPlatform (moveCall, cpyCall) <- forkAltPair (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags)) + (wordAlignment platform)) (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags)) + (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff @@ -2660,10 +2658,9 @@ doCopySmallArrayOp = emitCopySmallArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - do dflags <- getDynFlags - platform <- getPlatform + do platform <- getPlatform emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags) + (wordAlignment platform) doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff @@ -2674,13 +2671,12 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do - dflags <- getDynFlags platform <- getPlatform (moveCall, cpyCall) <- forkAltPair (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags)) + (wordAlignment platform)) (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment dflags)) + (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff @@ -2750,7 +2746,7 @@ emitCloneArray info_p res_r src src_off n = do (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) - (wordAlignment dflags) + (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2788,7 +2784,7 @@ emitCloneSmallArray info_p res_r src src_off n = do (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) - (wordAlignment dflags) + (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 44a1b10efb..c472a2815b 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- @@ -453,8 +454,10 @@ tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () -- used to distinguish between closure types -- -- TODO what else to count while we're here? -tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> - let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep +tickyDynAlloc mb_id rep lf = ifTicky $ do + dflags <- getDynFlags + let platform = targetPlatform dflags + bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes @@ -471,19 +474,18 @@ tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> -- for now, since I don't currently know neither if we do nor how to -- distinguish. NSF Mar 2013 - in case () of - _ | isConRep rep -> - ifTickyDynThunk countSpecific >> - countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") - | isThunkRep rep -> - ifTickyDynThunk countSpecific >> - if lfUpdatable lf - then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") - else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") - | isFunRep rep -> - countSpecific >> - countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") - | otherwise -> panic "How is this heap object not a con, thunk, or fun?" + if | isConRep rep -> + ifTickyDynThunk countSpecific >> + countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") + | isThunkRep rep -> + ifTickyDynThunk countSpecific >> + if lfUpdatable lf + then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr") + else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr") + | isFunRep rep -> + countSpecific >> + countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr") + | otherwise -> panic "How is this heap object not a con, thunk, or fun?" diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index f212022822..178572eb64 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -520,7 +520,6 @@ emitCmmLitSwitch scrut branches deflt = do deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches - dflags <- getDynFlags platform <- getPlatform let cmm_ty = cmmExprType platform scrut rep = typeWidth cmm_ty @@ -530,8 +529,8 @@ emitCmmLitSwitch scrut branches deflt = do (LitNumber nt _ _, _) -> litNumIsSigned nt _ -> False - let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags) - | otherwise = (0, tARGET_MAX_WORD dflags) + let range | signed = (platformMinInt platform, platformMaxInt platform) + | otherwise = (0, platformMaxWord platform) if isFloatType cmm_ty then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 41b453a9fa..cd8a63e2ca 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -33,7 +33,7 @@ module Literal -- ** Predicates on Literals and their contents , litIsDupable, litIsTrivial, litIsLifted - , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange + , inCharRange , isZeroLit , litFitsInChar , litValue, isLitValue, isLitValue_maybe, mapLitValue @@ -61,7 +61,6 @@ import FastString import BasicTypes import Binary import Constants -import GHC.Driver.Session import GHC.Platform import UniqFM import Util @@ -305,12 +304,12 @@ Int/Word range. -} -- | Wrap a literal number according to its type -wrapLitNumber :: DynFlags -> Literal -> Literal -wrapLitNumber dflags v@(LitNumber nt i t) = case nt of - LitNumInt -> case platformWordSize (targetPlatform dflags) of +wrapLitNumber :: Platform -> Literal -> Literal +wrapLitNumber platform v@(LitNumber nt i t) = case nt of + LitNumInt -> case platformWordSize platform of PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord -> case platformWordSize (targetPlatform dflags) of + LitNumWord -> case platformWordSize platform of PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t @@ -320,35 +319,35 @@ wrapLitNumber dflags v@(LitNumber nt i t) = case nt of wrapLitNumber _ x = x -- | Create a numeric 'Literal' of the given type -mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t) -- | Check that a given number is in the range of a numeric literal -litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool -litNumCheckRange dflags nt i = case nt of - LitNumInt -> inIntRange dflags i - LitNumWord -> inWordRange dflags i +litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool +litNumCheckRange platform nt i = case nt of + LitNumInt -> platformInIntRange platform i + LitNumWord -> platformInWordRange platform i LitNumInt64 -> inInt64Range i LitNumWord64 -> inWord64Range i LitNumNatural -> i >= 0 LitNumInteger -> True -- | Create a numeric 'Literal' of the given type -mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal -mkLitNumber dflags nt i t = - ASSERT2(litNumCheckRange dflags nt i, integer i) +mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal +mkLitNumber platform nt i t = + ASSERT2(litNumCheckRange platform nt i, integer i) (LitNumber nt i t) -- | Creates a 'Literal' of type @Int#@ -mkLitInt :: DynFlags -> Integer -> Literal -mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) +mkLitInt :: Platform -> Integer -> Literal +mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x ) (mkLitIntUnchecked x) -- | Creates a 'Literal' of type @Int#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] -mkLitIntWrap :: DynFlags -> Integer -> Literal -mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i +mkLitIntWrap :: Platform -> Integer -> Literal +mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i -- | Creates a 'Literal' of type @Int#@ without checking its range. mkLitIntUnchecked :: Integer -> Literal @@ -358,21 +357,21 @@ mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy -- overflow. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the overflow flag will be set. -- See Note [Word/Int underflow/overflow] -mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitIntWrapC dflags i = (n, i /= i') +mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitIntWrapC platform i = (n, i /= i') where - n@(LitNumber _ i' _) = mkLitIntWrap dflags i + n@(LitNumber _ i' _) = mkLitIntWrap platform i -- | Creates a 'Literal' of type @Word#@ -mkLitWord :: DynFlags -> Integer -> Literal -mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) +mkLitWord :: Platform -> Integer -> Literal +mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x ) (mkLitWordUnchecked x) -- | Creates a 'Literal' of type @Word#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] -mkLitWordWrap :: DynFlags -> Integer -> Literal -mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i +mkLitWordWrap :: Platform -> Integer -> Literal +mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i -- | Creates a 'Literal' of type @Word#@ without checking its range. mkLitWordUnchecked :: Integer -> Literal @@ -382,10 +381,10 @@ mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy -- carry. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the carry flag will be set. -- See Note [Word/Int underflow/overflow] -mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkLitWordWrapC dflags i = (n, i /= i') +mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) +mkLitWordWrapC platform i = (n, i /= i') where - n@(LitNumber _ i' _) = mkLitWordWrap dflags i + n@(LitNumber _ i' _) = mkLitWordWrap platform i -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal @@ -393,8 +392,8 @@ mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) -- | Creates a 'Literal' of type @Int64#@. -- If the argument is out of the range, it is wrapped. -mkLitInt64Wrap :: DynFlags -> Integer -> Literal -mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i +mkLitInt64Wrap :: Platform -> Integer -> Literal +mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i -- | Creates a 'Literal' of type @Int64#@ without checking its range. mkLitInt64Unchecked :: Integer -> Literal @@ -406,8 +405,8 @@ mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) -- | Creates a 'Literal' of type @Word64#@. -- If the argument is out of the range, it is wrapped. -mkLitWord64Wrap :: DynFlags -> Integer -> Literal -mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i +mkLitWord64Wrap :: Platform -> Integer -> Literal +mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i -- | Creates a 'Literal' of type @Word64#@ without checking its range. mkLitWord64Unchecked :: Integer -> Literal @@ -438,10 +437,6 @@ mkLitNatural :: Integer -> Type -> Literal mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) (LitNumber LitNumNatural x ty) -inIntRange, inWordRange :: DynFlags -> Integer -> Bool -inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags -inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags - inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 @@ -480,12 +475,12 @@ isLitValue_maybe _ = Nothing -- For fixed-size integral literals, the result will be wrapped in accordance -- with the semantics of the target type. -- See Note [Word/Int underflow/overflow] -mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (LitChar c) = mkLitChar (fchar c) +mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags +mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform (LitNumber nt (f i) t) -mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', -- 'Int', 'Word', 'LitInteger' and 'LitNatural'. @@ -504,21 +499,21 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit, float2DoubleLit, double2FloatLit :: Literal -> Literal -word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal -word2IntLit dflags (LitNumber LitNumWord w _) +word2IntLit, int2WordLit :: Platform -> Literal -> Literal +word2IntLit platform (LitNumber LitNumWord w _) -- Map Word range [max_int+1, max_word] -- to Int range [min_int , -1] -- Range [0,max_int] has the same representation with both Int and Word - | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) - | otherwise = mkLitInt dflags w + | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1) + | otherwise = mkLitInt platform w word2IntLit _ l = pprPanic "word2IntLit" (ppr l) -int2WordLit dflags (LitNumber LitNumInt i _) +int2WordLit platform (LitNumber LitNumInt i _) -- Map Int range [min_int , -1] -- to Word range [max_int+1, max_word] -- Range [0,max_int] has the same representation with both Int and Word - | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) - | otherwise = mkLitWord dflags i + | i < 0 = mkLitWord platform (1 + platformMaxWord platform + i) + | otherwise = mkLitWord platform i int2WordLit _ l = pprPanic "int2WordLit" (ppr l) -- | Narrow a literal number (unchecked result range) @@ -611,17 +606,18 @@ litIsTrivial (LitNumber nt _ _) = case nt of litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal -litIsDupable :: DynFlags -> Literal -> Bool +litIsDupable :: Platform -> Literal -> Bool -- c.f. GHC.Core.Utils.exprIsDupable -litIsDupable _ (LitString _) = False -litIsDupable dflags (LitNumber nt i _) = case nt of - LitNumInteger -> inIntRange dflags i - LitNumNatural -> inIntRange dflags i - LitNumInt -> True - LitNumInt64 -> True - LitNumWord -> True - LitNumWord64 -> True -litIsDupable _ _ = True +litIsDupable platform x = case x of + (LitNumber nt i _) -> case nt of + LitNumInteger -> platformInIntRange platform i + LitNumNatural -> platformInWordRange platform i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True + (LitString _) -> False + _ -> True litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs index cf3458507b..9935b03583 100644 --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -42,5 +42,9 @@ wORD64_SIZE = 8 fLOAT_SIZE :: Int fLOAT_SIZE = 4 +-- Size of double in bytes. +dOUBLE_SIZE :: Int +dOUBLE_SIZE = 8 + tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index ecc937665a..81a72230f3 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -178,6 +178,7 @@ sptCreateStaticBinds hsc_env this_mod binds go (reverse fps' ++ fps) (bnd' : bs) xs' dflags = hsc_dflags hsc_env + platform = targetPlatform dflags -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. -- @@ -219,8 +220,8 @@ sptCreateStaticBinds hsc_env this_mod binds staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName return (fp, mkConApp staticPtrDataCon [ Type t - , mkWord64LitWordRep dflags w0 - , mkWord64LitWordRep dflags w1 + , mkWord64LitWordRep platform w0 + , mkWord64LitWordRep platform w1 , info , e ]) @@ -233,10 +234,10 @@ sptCreateStaticBinds hsc_env this_mod binds -- Choose either 'Word64#' or 'Word#' to represent the arguments of the -- 'Fingerprint' data constructor. - mkWord64LitWordRep dflags = - case platformWordSize (targetPlatform dflags) of + mkWord64LitWordRep platform = + case platformWordSize platform of PW4 -> mkWord64LitWord64 - PW8 -> mkWordLit dflags . toInteger + PW8 -> mkWordLit platform . toInteger lookupIdHscEnv :: Name -> IO Id lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>= diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 741be62e03..d8abc88bf0 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -530,7 +530,8 @@ newOverloadedLit -- tauify the ExpType = do { res_ty <- expTypeToType res_ty ; dflags <- getDynFlags - ; case shortCutLit dflags val res_ty of + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs index 7eb9c598b4..ca3d1b3513 100644 --- a/compiler/typecheck/TcEvTerm.hs +++ b/compiler/typecheck/TcEvTerm.hs @@ -37,16 +37,17 @@ evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => -- See Note [Overview of implicit CallStacks] in TcEvidence.hs evCallStack cs = do df <- getDynFlags + let platform = targetPlatform df m <- getModule srcLocDataCon <- lookupDataCon srcLocDataConName let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) , mkStringExprFS (moduleNameFS $ moduleName m) , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt df (srcSpanStartLine l) - , return $ mkIntExprInt df (srcSpanStartCol l) - , return $ mkIntExprInt df (srcSpanEndLine l) - , return $ mkIntExprInt df (srcSpanEndCol l) + , return $ mkIntExprInt platform (srcSpanStartLine l) + , return $ mkIntExprInt platform (srcSpanStartCol l) + , return $ mkIntExprInt platform (srcSpanEndLine l) + , return $ mkIntExprInt platform (srcSpanEndCol l) ] emptyCS <- Var <$> lookupId emptyCallStackName diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 4a32bbef86..6fd7f6f0be 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -74,8 +74,7 @@ import Name import NameEnv import Var import VarEnv -import GHC.Driver.Session -import Literal +import GHC.Platform import BasicTypes import Maybes import SrcLoc @@ -146,12 +145,12 @@ hsLitType (XLit nec) = noExtCon nec -- Overloaded literals. Here mainly because it uses isIntTy etc -shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) -shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) +shortCutLit platform (HsIntegral int@(IL src neg i)) ty + | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty + | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 3f77146367..d1591ed1bf 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -13,6 +13,7 @@ module TcTypeable(mkTypeableBinds, tyConIsTypeable) where #include "HsVersions.h" import GhcPrelude +import GHC.Platform import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) @@ -354,7 +355,7 @@ ghcPrimTypeableTyCons = concat ] data TypeableStuff - = Stuff { dflags :: DynFlags + = Stuff { platform :: Platform -- ^ Target platform , trTyConDataCon :: DataCon -- ^ of @TyCon@ , trNameLit :: FastString -> LHsExpr GhcTc -- ^ To construct @TrName@s @@ -373,7 +374,7 @@ data TypeableStuff -- | Collect various tidbits which we'll need to generate TyCon representations. collect_stuff :: TcM TypeableStuff collect_stuff = do - dflags <- getDynFlags + platform <- targetPlatform <$> getDynFlags trTyConDataCon <- tcLookupDataCon trTyConDataConName kindRepTyCon <- tcLookupTyCon kindRepTyConName kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName @@ -619,8 +620,8 @@ mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 dflags high) - `nlHsApp` nlHsLit (word64 dflags low) + `nlHsApp` nlHsLit (word64 platform high) + `nlHsApp` nlHsLit (word64 platform low) `nlHsApp` mod_rep_expr todo `nlHsApp` trNameLit (mkFastString tycon_str) `nlHsApp` nlHsLit (int n_kind_vars) @@ -641,10 +642,10 @@ mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep int :: Int -> HsLit GhcTc int n = HsIntPrim (SourceText $ show n) (toInteger n) -word64 :: DynFlags -> Word64 -> HsLit GhcTc -word64 dflags n - | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n) - | otherwise = HsWordPrim NoSourceText (toInteger n) +word64 :: Platform -> Word64 -> HsLit GhcTc +word64 platform n = case platformWordSize platform of + PW4 -> HsWord64Prim NoSourceText (toInteger n) + PW8 -> HsWordPrim NoSourceText (toInteger n) {- Note [Representing TyCon kinds: KindRep] diff --git a/includes/MachDeps.h b/includes/MachDeps.h index 81d6641dff..98a90814d9 100644 --- a/includes/MachDeps.h +++ b/includes/MachDeps.h @@ -32,9 +32,7 @@ * * To get target's values it is preferred to use runtime target * configuration from 'targetPlatform :: DynFlags -> Platform' - * record. A few wrappers are already defined and used throughout GHC: - * wORD_SIZE :: DynFlags -> Int - * wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) + * record. * * Hence we hide these macros from GHC_STAGE=1 */ diff --git a/libraries/ghc-boot/GHC/Platform.hs b/libraries/ghc-boot/GHC/Platform.hs index 341b551fc5..f6a7060b3f 100644 --- a/libraries/ghc-boot/GHC/Platform.hs +++ b/libraries/ghc-boot/GHC/Platform.hs @@ -21,6 +21,11 @@ module GHC.Platform ( platformUsesFrameworks, platformWordSizeInBytes, platformWordSizeInBits, + platformMinInt, + platformMaxInt, + platformMaxWord, + platformInIntRange, + platformInWordRange, PlatformMisc(..), IntegerLibrary(..), @@ -33,6 +38,8 @@ where import Prelude -- See Note [Why do we import Prelude here?] import GHC.Read +import Data.Word +import Data.Int -- | Contains the bare-bones arch and os information. This isn't enough for -- code gen, but useful for tasks where we can fall back upon the host @@ -305,3 +312,29 @@ data IntegerLibrary = IntegerGMP | IntegerSimple deriving (Read, Show, Eq) + +-- | Minimum representable Int value for the given platform +platformMinInt :: Platform -> Integer +platformMinInt p = case platformWordSize p of + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) + +-- | Maximum representable Int value for the given platform +platformMaxInt :: Platform -> Integer +platformMaxInt p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) + +-- | Maximum representable Word value for the given platform +platformMaxWord :: Platform -> Integer +platformMaxWord p = case platformWordSize p of + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) + +-- | Test if the given Integer is representable with a platform Int +platformInIntRange :: Platform -> Integer -> Bool +platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform + +-- | Test if the given Integer is representable with a platform Word +platformInWordRange :: Platform -> Integer -> Bool +platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs index f6f590715b..d4143e988a 100644 --- a/utils/deriveConstants/Main.hs +++ b/utils/deriveConstants/Main.hs @@ -661,9 +661,6 @@ wanteds os = concat -- Size of a word, in bytes ,constantWord Haskell "WORD_SIZE" "SIZEOF_HSWORD" - -- Size of a double in StgWords. - ,constantWord Haskell "DOUBLE_SIZE" "SIZEOF_DOUBLE" - -- Size of a C int, in bytes. May be smaller than wORD_SIZE. ,constantWord Haskell "CINT_SIZE" "SIZEOF_INT" ,constantWord Haskell "CLONG_SIZE" "SIZEOF_LONG" |