summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/ByteCode/Asm.hs51
-rw-r--r--compiler/GHC/Cmm/Lint.hs6
-rw-r--r--compiler/GHC/Cmm/Parser.y21
-rw-r--r--compiler/GHC/Cmm/Utils.hs11
-rw-r--r--compiler/GHC/CmmToAsm/Config.hs7
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs19
-rw-r--r--compiler/GHC/Core.hs29
-rw-r--r--compiler/GHC/Core/Lint.hs6
-rw-r--r--compiler/GHC/Core/Make.hs18
-rw-r--r--compiler/GHC/Core/Op/ConstantFold.hs906
-rw-r--r--compiler/GHC/Core/Op/FloatIn.hs100
-rw-r--r--compiler/GHC/Core/Op/Simplify.hs11
-rw-r--r--compiler/GHC/Core/Op/Simplify/Utils.hs2
-rw-r--r--compiler/GHC/Core/Rules.hs9
-rw-r--r--compiler/GHC/Core/TyCon.hs52
-rw-r--r--compiler/GHC/Core/Utils.hs8
-rw-r--r--compiler/GHC/CoreToByteCode.hs74
-rw-r--r--compiler/GHC/CoreToStg.hs4
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs29
-rw-r--r--compiler/GHC/Driver/Session.hs26
-rw-r--r--compiler/GHC/HsToCore/Expr.hs6
-rw-r--r--compiler/GHC/HsToCore/Foreign/Call.hs22
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs18
-rw-r--r--compiler/GHC/HsToCore/Match.hs14
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs38
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs3
-rw-r--r--compiler/GHC/HsToCore/Quote.hs40
-rw-r--r--compiler/GHC/Iface/Binary.hs12
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs8
-rw-r--r--compiler/GHC/Stg/Lift/Analysis.hs10
-rw-r--r--compiler/GHC/StgToCmm/ArgRep.hs29
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs16
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs7
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs3
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs18
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs28
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs32
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs5
-rw-r--r--compiler/basicTypes/Literal.hs112
-rw-r--r--compiler/main/Constants.hs4
-rw-r--r--compiler/main/StaticPtrTable.hs11
-rw-r--r--compiler/typecheck/Inst.hs3
-rw-r--r--compiler/typecheck/TcEvTerm.hs9
-rw-r--r--compiler/typecheck/TcHsSyn.hs13
-rw-r--r--compiler/typecheck/TcTypeable.hs17
-rw-r--r--includes/MachDeps.h4
-rw-r--r--libraries/ghc-boot/GHC/Platform.hs33
-rw-r--r--utils/deriveConstants/Main.hs3
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"