summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-03-09 19:59:01 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-03-19 12:16:49 -0400
commit64f207566931469648e791df4f0f0384d45cddd0 (patch)
tree58e8a6e27d192368b1ddbc47e9bb89046b2a24a4 /compiler
parentb03fd3bcd4ff14aed2942275c3b0db5392dc913c (diff)
downloadhaskell-64f207566931469648e791df4f0f0384d45cddd0.tar.gz
Refactoring: use Platform instead of DynFlags when possible
Metric Decrease: ManyConstructors T12707 T13035 T1969
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/ByteCode/Asm.hs51
-rw-r--r--compiler/GHC/Cmm/CallConv.hs26
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs21
-rw-r--r--compiler/GHC/Cmm/Expr.hs110
-rw-r--r--compiler/GHC/Cmm/Graph.hs46
-rw-r--r--compiler/GHC/Cmm/Info.hs114
-rw-r--r--compiler/GHC/Cmm/Info/Build.hs3
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs136
-rw-r--r--compiler/GHC/Cmm/Lint.hs38
-rw-r--r--compiler/GHC/Cmm/MachOp.hs156
-rw-r--r--compiler/GHC/Cmm/Opt.hs91
-rw-r--r--compiler/GHC/Cmm/Parser.y26
-rw-r--r--compiler/GHC/Cmm/Pipeline.hs2
-rw-r--r--compiler/GHC/Cmm/Ppr.hs12
-rw-r--r--compiler/GHC/Cmm/Ppr/Decl.hs10
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs87
-rw-r--r--compiler/GHC/Cmm/Sink.hs55
-rw-r--r--compiler/GHC/Cmm/Switch/Implement.hs27
-rw-r--r--compiler/GHC/Cmm/Type.hs44
-rw-r--r--compiler/GHC/Cmm/Utils.hs259
-rw-r--r--compiler/GHC/CmmToAsm.hs10
-rw-r--r--compiler/GHC/CmmToAsm/PIC.hs82
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs153
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Ppr.hs3
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen.hs54
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs4
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs7
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs6
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs16
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Ppr.hs19
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs480
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs7
-rw-r--r--compiler/GHC/CmmToC.hs516
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs51
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs152
-rw-r--r--compiler/GHC/CmmToLlvm/Data.hs12
-rw-r--r--compiler/GHC/CmmToLlvm/Ppr.hs5
-rw-r--r--compiler/GHC/CmmToLlvm/Regs.hs18
-rw-r--r--compiler/GHC/CoreToByteCode.hs133
-rw-r--r--compiler/GHC/Data/Bitmap.hs31
-rw-r--r--compiler/GHC/Driver/Session.hs4
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs34
-rw-r--r--compiler/GHC/Llvm/Ppr.hs63
-rw-r--r--compiler/GHC/Llvm/Types.hs49
-rw-r--r--compiler/GHC/Runtime/Heap/Layout.hs67
-rw-r--r--compiler/GHC/StgToCmm.hs3
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs28
-rw-r--r--compiler/GHC/StgToCmm/CgUtils.hs8
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs7
-rw-r--r--compiler/GHC/StgToCmm/Env.hs33
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs33
-rw-r--r--compiler/GHC/StgToCmm/Foreign.hs110
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs49
-rw-r--r--compiler/GHC/StgToCmm/Hpc.hs7
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs25
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs24
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs952
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs108
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs49
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs122
60 files changed, 2530 insertions, 2318 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index c781a3a6d1..d9ab36704d 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -164,6 +164,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs
+ platform = targetPlatform dflags
initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants
@@ -174,9 +175,9 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- and if the final size is indeed small enough for short jumps, we are
-- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long.
- (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
+ (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
((n_insns, lbl_map), long_jumps)
- | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
+ | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)
| otherwise = ((n_insns0, lbl_map0), False)
env :: Word16 -> Word
@@ -186,7 +187,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 2: run assembler and generate instructions, literals and pointers
let initial_state = (emptySS, emptySS, emptySS)
- (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
+ (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
-- precomputed size should be equal to final size
ASSERT(n_insns == sizeSS final_insns) return ()
@@ -265,8 +266,8 @@ largeOp long_jumps op = case op of
LabelOp _ -> long_jumps
-- LargeOp _ -> True
-runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
-runAsm dflags long_jumps e = go
+runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
+runAsm platform long_jumps e = go
where
go (NullAsm x) = return x
go (AllocPtr p_io k) = do
@@ -289,8 +290,8 @@ runAsm dflags long_jumps e = go
words = concatMap expand ops
expand (SmallOp w) = [w]
expand (LabelOp w) = expand (Op (e w))
- expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
--- expand (LargeOp w) = largeArg dflags w
+ expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]
+-- expand (LargeOp w) = largeArg platform w
state $ \(st_i0,st_l0,st_p0) ->
let st_i1 = addListToSS st_i0 (opcode : words)
in ((), (st_i1,st_l0,st_p0))
@@ -305,8 +306,8 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
-inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
-inspectAsm dflags long_jumps initial_offset
+inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
+inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
where
go s (NullAsm _) = (instrCount s, lblEnv s)
@@ -323,8 +324,8 @@ inspectAsm dflags long_jumps initial_offset
largeOps = any (largeOp long_jumps) ops
count (SmallOp _) = 1
count (LabelOp _) = count (Op 0)
- count (Op _) = if largeOps then largeArg16s dflags else 1
--- count (LargeOp _) = largeArg16s dflags
+ count (Op _) = if largeOps then largeArg16s platform else 1
+-- count (LargeOp _) = largeArg16s platform
-- Bring in all the bci_ bytecode constants.
#include "rts/Bytecodes.h"
@@ -332,21 +333,19 @@ inspectAsm dflags long_jumps initial_offset
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
-largeArg :: DynFlags -> Word -> [Word16]
-largeArg dflags w
- | wORD_SIZE_IN_BITS dflags == 64
- = [fromIntegral (w `shiftR` 48),
- fromIntegral (w `shiftR` 32),
- fromIntegral (w `shiftR` 16),
- fromIntegral w]
- | wORD_SIZE_IN_BITS dflags == 32
- = [fromIntegral (w `shiftR` 16),
- fromIntegral w]
- | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-
-largeArg16s :: DynFlags -> Word
-largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
- | otherwise = 2
+largeArg :: Platform -> Word -> [Word16]
+largeArg platform w = case platformWordSize platform of
+ PW8 -> [fromIntegral (w `shiftR` 48),
+ fromIntegral (w `shiftR` 32),
+ fromIntegral (w `shiftR` 16),
+ fromIntegral w]
+ PW4 -> [fromIntegral (w `shiftR` 16),
+ fromIntegral w]
+
+largeArg16s :: Platform -> Word
+largeArg16s platform = case platformWordSize platform of
+ PW8 -> 4
+ PW4 -> 2
assembleI :: DynFlags
-> BCInstr
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index 40f348f9e0..6cd66be30c 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -43,6 +43,7 @@ assignArgumentsPos :: DynFlags
assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
where
+ platform = targetPlatform dflags
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
@@ -57,7 +58,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
-- different type). When returning an unboxed tuple, we also
-- separate the stack arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs
- (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args
+ (stk_off, stk_assts) = assignStack platform off arg_ty stk_args
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
@@ -84,9 +85,9 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
- (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
+ (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
- (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
+ (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)
-> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
@@ -94,10 +95,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
- passFloatInXmm = passFloatArgsInXmm dflags
+ passFloatInXmm = passFloatArgsInXmm platform
-passFloatArgsInXmm :: DynFlags -> Bool
-passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+passFloatArgsInXmm :: Platform -> Bool
+passFloatArgsInXmm platform = case platformArch platform of
ArchX86_64 -> True
ArchX86 -> False
_ -> False
@@ -109,12 +110,12 @@ passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
passVectorInReg :: Width -> DynFlags -> Bool
passVectorInReg _ _ = True
-assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
-> (
ByteOff -- bytes of stack args
, [(a, ParamLocation)] -- args and locations
)
-assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)
where
assign_stk offset assts [] = (offset, assts)
assign_stk offset assts (r:rs)
@@ -123,7 +124,7 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
off' = offset + size
-- Stack arguments always take a whole number of words, we never
-- pack them unlike constructor fields.
- size = roundUpToWords dflags (widthInBytes w)
+ size = roundUpToWords platform (widthInBytes w)
-----------------------------------------------------------------------------
-- Local information about the registers available
@@ -202,9 +203,10 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
- | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
- realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
+ | passFloatArgsInXmm (targetPlatform dflags)
+ = map ($VGcPtr) (realVanillaRegs dflags) ++
+ realLongRegs dflags ++
+ map XmmReg (realXmmRegNos dflags)
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 23da957f9e..9d2da26b93 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -27,6 +27,7 @@ module GHC.Cmm.DebugBlock (
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
@@ -525,14 +526,14 @@ instance Outputable UnwindExpr where
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
-- possible.
-toUnwindExpr :: CmmExpr -> UnwindExpr
-toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
-toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l
-toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
-toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
-toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
-toUnwindExpr e@(CmmMachOp op [e1, e2]) =
- case (op, toUnwindExpr e1, toUnwindExpr e2) of
+toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
+toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
+toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l
+toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
+toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0
+toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)
+toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
+ case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
(MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
(MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
(MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
@@ -543,6 +544,6 @@ toUnwindExpr e@(CmmMachOp op [e1, e2]) =
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
- (pprExpr e)
-toUnwindExpr e
+ (pprExpr platform e)
+toUnwindExpr _ e
= pprPanic "Unsupported unwind expression!" (ppr e)
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index 9be4200f85..3c92c1e61b 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -32,6 +33,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
@@ -209,37 +211,39 @@ data CmmLit
-- of bytes used
deriving Eq
-cmmExprType :: DynFlags -> CmmExpr -> CmmType
-cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit
-cmmExprType _ (CmmLoad _ rep) = rep
-cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg
-cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
-cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg
-cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address
--- Careful though: what is stored at the stack slot may be bigger than
--- an address
-
-cmmLitType :: DynFlags -> CmmLit -> CmmType
-cmmLitType _ (CmmInt _ width) = cmmBits width
-cmmLitType _ (CmmFloat _ width) = cmmFloat width
-cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []"
-cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l
- in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
- then cmmVec (1+length ls) ty
- else panic "cmmLitType: CmmVec"
-cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
-cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
-cmmLitType _ (CmmLabelDiffOff _ _ _ width) = cmmBits width
-cmmLitType dflags (CmmBlock _) = bWord dflags
-cmmLitType dflags (CmmHighStackMark) = bWord dflags
-
-cmmLabelType :: DynFlags -> CLabel -> CmmType
-cmmLabelType dflags lbl
- | isGcPtrLabel lbl = gcWord dflags
- | otherwise = bWord dflags
-
-cmmExprWidth :: DynFlags -> CmmExpr -> Width
-cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
+cmmExprType :: Platform -> CmmExpr -> CmmType
+cmmExprType platform = \case
+ (CmmLit lit) -> cmmLitType platform lit
+ (CmmLoad _ rep) -> rep
+ (CmmReg reg) -> cmmRegType platform reg
+ (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
+ (CmmRegOff reg _) -> cmmRegType platform reg
+ (CmmStackSlot _ _) -> bWord platform -- an address
+ -- Careful though: what is stored at the stack slot may be bigger than
+ -- an address
+
+cmmLitType :: Platform -> CmmLit -> CmmType
+cmmLitType platform = \case
+ (CmmInt _ width) -> cmmBits width
+ (CmmFloat _ width) -> cmmFloat width
+ (CmmVec []) -> panic "cmmLitType: CmmVec []"
+ (CmmVec (l:ls)) -> let ty = cmmLitType platform l
+ in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)
+ then cmmVec (1+length ls) ty
+ else panic "cmmLitType: CmmVec"
+ (CmmLabel lbl) -> cmmLabelType platform lbl
+ (CmmLabelOff lbl _) -> cmmLabelType platform lbl
+ (CmmLabelDiffOff _ _ _ width) -> cmmBits width
+ (CmmBlock _) -> bWord platform
+ (CmmHighStackMark) -> bWord platform
+
+cmmLabelType :: Platform -> CLabel -> CmmType
+cmmLabelType platform lbl
+ | isGcPtrLabel lbl = gcWord platform
+ | otherwise = bWord platform
+
+cmmExprWidth :: Platform -> CmmExpr -> Width
+cmmExprWidth platform e = typeWidth (cmmExprType platform e)
-- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte.
@@ -278,12 +282,12 @@ instance Ord LocalReg where
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
-cmmRegType :: DynFlags -> CmmReg -> CmmType
-cmmRegType _ (CmmLocal reg) = localRegType reg
-cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
+cmmRegType :: Platform -> CmmReg -> CmmType
+cmmRegType _ (CmmLocal reg) = localRegType reg
+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
-cmmRegWidth :: DynFlags -> CmmReg -> Width
-cmmRegWidth dflags = typeWidth . cmmRegType dflags
+cmmRegWidth :: Platform -> CmmReg -> Width
+cmmRegWidth platform = typeWidth . cmmRegType platform
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
@@ -590,23 +594,23 @@ cccsReg = CmmGlobal CCCS
node :: GlobalReg
node = VanillaReg 1 VGcPtr
-globalRegType :: DynFlags -> GlobalReg -> CmmType
-globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags
-globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
-globalRegType _ (FloatReg _) = cmmFloat W32
-globalRegType _ (DoubleReg _) = cmmFloat W64
-globalRegType _ (LongReg _) = cmmBits W64
--- TODO: improve the internal model of SIMD/vectorized registers
--- the right design SHOULd improve handling of float and double code too.
--- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
-globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32)
-globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32)
-globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32)
-
-globalRegType dflags Hp = gcWord dflags
- -- The initialiser for all
- -- dynamically allocated closures
-globalRegType dflags _ = bWord dflags
+globalRegType :: Platform -> GlobalReg -> CmmType
+globalRegType platform = \case
+ (VanillaReg _ VGcPtr) -> gcWord platform
+ (VanillaReg _ VNonGcPtr) -> bWord platform
+ (FloatReg _) -> cmmFloat W32
+ (DoubleReg _) -> cmmFloat W64
+ (LongReg _) -> cmmBits W64
+ -- TODO: improve the internal model of SIMD/vectorized registers
+ -- the right design SHOULd improve handling of float and double code too.
+ -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
+ (XmmReg _) -> cmmVec 4 (cmmBits W32)
+ (YmmReg _) -> cmmVec 8 (cmmBits W32)
+ (ZmmReg _) -> cmmVec 16 (cmmBits W32)
+
+ Hp -> gcWord platform -- The initialiser for all
+ -- dynamically allocated closures
+ _ -> bWord platform
isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index c07f694897..413bce3f1e 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -310,15 +310,16 @@ copyIn :: DynFlags -> Convention -> Area
copyIn dflags conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where
+ platform = targetPlatform dflags
-- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg
global = CmmReg (CmmGlobal r)
- width = cmmRegWidth dflags local
+ width = cmmRegWidth platform local
expr
- | width == wordWidth dflags = global
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+ | width == wordWidth platform = global
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]
| otherwise = panic "Parameter width greater than word width"
in CmmAssign local expr
@@ -329,21 +330,21 @@ copyIn dflags conv area formals extra_stk
ci (reg, StackParam off)
| isBitsType $ localRegType reg
- , typeWidth (localRegType reg) < wordWidth dflags =
+ , typeWidth (localRegType reg) < wordWidth platform =
let
- stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+ stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))
local = CmmLocal reg
- width = cmmRegWidth dflags local
- expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
+ width = cmmRegWidth platform local
+ expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
in CmmAssign local expr
| otherwise =
CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
where ty = localRegType reg
- init_offset = widthInBytes (wordWidth dflags) -- infotable
+ init_offset = widthInBytes (wordWidth platform) -- infotable
- (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+ (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk
(stk_size, args) = assignArgumentsPos dflags stk_off conv
localRegType formals
@@ -370,15 +371,16 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
= (stk_size, regs, graph)
where
+ platform = targetPlatform dflags
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters]
co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
- let width = cmmExprWidth dflags v
+ let width = cmmExprWidth platform v
value
- | width == wordWidth dflags = v
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+ | width == wordWidth platform = v
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]
| otherwise = panic "Parameter width greater than word width"
in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
@@ -391,11 +393,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
co (v, StackParam off) (rs, ms)
= (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
- width v = cmmExprWidth dflags v
+ width v = cmmExprWidth platform v
value v
- | isBitsType $ cmmExprType dflags v
- , width v < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+ | isBitsType $ cmmExprType platform v
+ , width v < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]
| otherwise = v
(setRA, init_offset) =
@@ -405,20 +407,20 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
case transfer of
Call ->
([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
JumpRet ->
([],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
_other ->
([], 0)
Old -> ([], updfr_off)
(extra_stack_off, stack_params) =
- assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+ assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
(stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
- (cmmExprType dflags) actuals
+ (cmmExprType platform) actuals
-- Note [Width of parameters]
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 6b2a3d82c6..7a1bc2d3d1 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -194,7 +194,7 @@ mkInfoTableContents dflags
-- (which in turn came from a handwritten .cmm file)
| StackRep frame <- smrep
- = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+ = do { (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
; let
@@ -207,7 +207,7 @@ mkInfoTableContents dflags
| HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let layout = packIntsCLit dflags ptrs nonptrs
- ; (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
@@ -217,6 +217,7 @@ mkInfoTableContents dflags
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
where
+ platform = targetPlatform dflags
mk_pieces :: ClosureTypeInfo -> [CmmLit]
-> UniqSM ( Maybe CmmLit -- Override the SRT field with this
, Maybe CmmLit -- Override the layout field with this
@@ -225,15 +226,15 @@ mkInfoTableContents dflags
mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
= do { (descr_lit, decl) <- newStringLit con_descr
; return ( Just (CmmInt (fromIntegral con_tag)
- (halfWordWidth dflags))
+ (halfWordWidth platform))
, Nothing, [descr_lit], [decl]) }
mk_pieces Thunk srt_label
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
- = return (Just (CmmInt 0 (halfWordWidth dflags)),
- Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+ = return (Just (CmmInt 0 (halfWordWidth platform)),
+ Just (mkWordCLit platform (fromIntegral offset)), [], [])
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
@@ -251,7 +252,7 @@ mkInfoTableContents dflags
where
slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
srt_lit = case srt_label of
- [] -> mkIntCLit dflags 0
+ [] -> mkIntCLit platform 0
(lit:_rest) -> ASSERT( null _rest ) lit
mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
@@ -260,8 +261,9 @@ mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt
packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
packIntsCLit dflags a b = packHalfWordsCLit dflags
- (toStgHalfWord dflags (fromIntegral a))
- (toStgHalfWord dflags (fromIntegral b))
+ (toStgHalfWord platform (fromIntegral a))
+ (toStgHalfWord platform (fromIntegral b))
+ where platform = targetPlatform dflags
mkSRTLit :: DynFlags
@@ -271,9 +273,9 @@ mkSRTLit :: DynFlags
CmmLit) -- srt_bitmap
mkSRTLit dflags info_lbl (Just lbl)
| inlineSRT dflags
- = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
-mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth dflags))
-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+ = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth (targetPlatform dflags)))
+mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth (targetPlatform dflags)))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth (targetPlatform dflags)))
-- | Is the SRT offset field inline in the info table on this platform?
@@ -314,10 +316,10 @@ makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
| tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
+ = CmmLabelDiffOff lbl info_lbl 0 (wordWidth (targetPlatform dflags))
makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
| tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
+ = CmmLabelDiffOff lbl info_lbl off (wordWidth (targetPlatform dflags))
makeRelativeRefTo _ _ lit = lit
@@ -347,29 +349,30 @@ mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
-- 2. Large bitmap CmmData if needed
mkLivenessBits dflags liveness
- | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+ | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word
= do { uniq <- getUniqueM
; let bitmap_lbl = mkBitmapLabel uniq
; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word
- = return (mkStgWordCLit dflags bitmap_word, [])
+ = return (mkStgWordCLit platform bitmap_word, [])
where
+ platform = targetPlatform dflags
n_bits = length liveness
bitmap :: Bitmap
- bitmap = mkBitmap dflags liveness
+ bitmap = mkBitmap platform liveness
small_bitmap = case bitmap of
- [] -> toStgWord dflags 0
+ [] -> toStgWord platform 0
[b] -> b
_ -> panic "mkLiveness"
- bitmap_word = toStgWord dflags (fromIntegral n_bits)
+ bitmap_word = toStgWord platform (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
- lits = mkWordCLit dflags (fromIntegral n_bits)
- : map (mkStgWordCLit dflags) bitmap
+ lits = mkWordCLit platform (fromIntegral n_bits)
+ : map (mkStgWordCLit platform) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
@@ -402,11 +405,12 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
++ [layout_lit, tag, srt]
where
+ platform = targetPlatform dflags
prof_info
| gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = []
- tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+ tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)
-------------------------------------------------------------------------
--
@@ -414,8 +418,8 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
--
-------------------------------------------------------------------------
-mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
mkProfLits _ (ProfilingInfo td cd)
= do { (td_lit, td_decl) <- newStringLit td
; (cd_lit, cd_decl) <- newStringLit cd
@@ -430,8 +434,8 @@ newStringLit bytes
-- Misc utils
-- | Value of the srt field of an info table when using an StgLargeSRT
-srtEscape :: DynFlags -> StgHalfWord
-srtEscape dflags = toStgHalfWord dflags (-1)
+srtEscape :: Platform -> StgHalfWord
+srtEscape platform = toStgHalfWord platform (-1)
-------------------------------------------------------------------------
--
@@ -444,21 +448,22 @@ srtEscape dflags = toStgHalfWord dflags (-1)
wordAligned :: DynFlags -> CmmExpr -> CmmExpr
wordAligned dflags e
| gopt Opt_AlignmentSanitisation dflags
- = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+ = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
+ where platform = targetPlatform dflags
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr dflags e =
- CmmLoad (wordAligned dflags e) (bWord dflags)
+ CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode dflags e
| tablesNextToCode dflags = e
- | otherwise = CmmLoad e (bWord dflags)
+ | otherwise = CmmLoad e (bWord (targetPlatform dflags))
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
@@ -466,25 +471,28 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ platform = targetPlatform dflags
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ platform = targetPlatform dflags
infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable dflags info_ptr
- | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
- | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+ | tablesNextToCode dflags = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)
+ | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer
+ where platform = targetPlatform dflags
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the constr tag
@@ -495,21 +503,25 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
@@ -517,16 +529,19 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- in the info table.
funInfoTable dflags info_ptr
| tablesNextToCode dflags
- = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+ = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
- = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
- -- Past the entry code pointer
+ = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)
+ -- Past the entry code pointer
+ where
+ platform = targetPlatform dflags
-- Takes the info pointer of a function, returns the function's arity
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity dflags iptr
- = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+ = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
+ platform = targetPlatform dflags
fun_info = funInfoTable dflags iptr
rep = cmmBits (widthFromBytes rep_bytes)
@@ -572,20 +587,27 @@ maxRetInfoTableSizeW =
+ 1 {- srt label -}
stdInfoTableSizeB :: DynFlags -> ByteOff
-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform
+ where platform = targetPlatform dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
-stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags
+stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
+
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform
+ where platform = targetPlatform dflags
conInfoTableSizeB :: DynFlags -> Int
-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index 54a7d8fb91..274345ab7a 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -1086,12 +1086,13 @@ buildSRT dflags refs = do
id <- getUniqueM
let
lbl = mkSRTLabel id
+ platform = targetPlatform dflags
srt_n_info = mkSRTInfoLabel (length refs)
fields =
mkStaticClosure dflags srt_n_info dontCareCCS
[ CmmLabel lbl | SRTEntry lbl <- refs ]
[] -- no padding
- [mkIntCLit dflags 0] -- link field
+ [mkIntCLit platform 0] -- link field
[] -- no saved info
return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 2b6051dd38..ba480a25b7 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -29,6 +29,7 @@ import Maybes
import UniqFM
import Util
+import GHC.Platform
import GHC.Driver.Session
import FastString
import Outputable hiding ( isEmpty )
@@ -459,7 +460,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
- return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+ return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
-- one word of args: the return address
CmmBranch {} -> handleBranches
@@ -467,6 +468,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
CmmSwitch {} -> handleBranches
where
+ platform = targetPlatform dflags
-- Calls and ForeignCalls are handled the same way:
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
@@ -495,7 +497,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= (save_assignments, new_cont_stack)
where
(new_cont_stack, save_assignments)
- = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
+ = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0
-- For other last nodes (branches), if any of the targets is a
@@ -518,7 +520,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
out = mapFromList [ (l', cont_stack)
| l' <- successors last ]
return ( assigs
- , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
+ , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform)
, last
, []
, out)
@@ -552,7 +554,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= do
let cont_args = mapFindWithDefault 0 l cont_info
(stack2, assigs) =
- setupStackFrame dflags l liveness (sm_ret_off stack0)
+ setupStackFrame platform l liveness (sm_ret_off stack0)
cont_args stack0
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block)
@@ -609,7 +611,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
- :: DynFlags
+ :: Platform
-> BlockId -- label of continuation
-> LabelMap CmmLocalLive -- liveness
-> ByteOff -- updfr
@@ -617,7 +619,7 @@ setupStackFrame
-> StackMap -- current StackMap
-> (StackMap, [CmmNode O O])
-setupStackFrame dflags lbl liveness updfr_off ret_args stack0
+setupStackFrame platform lbl liveness updfr_off ret_args stack0
= (cont_stack, assignments)
where
-- get the set of LocalRegs live in the continuation
@@ -633,7 +635,7 @@ setupStackFrame dflags lbl liveness updfr_off ret_args stack0
-- everything up to updfr_off is off-limits
-- stack1 contains updfr_off, plus everything we need to save
- (stack1, assignments) = allocate dflags updfr_off live stack0
+ (stack1, assignments) = allocate platform updfr_off live stack0
-- And the Sp at the continuation is:
-- sm_sp stack1 + ret_args
@@ -714,9 +716,9 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
-allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
-allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
=
-- we only have to save regs that are not already in a slot
@@ -726,38 +728,38 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- make a map of the stack
let stack = reverse $ Array.elems $
- accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
+ accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $
ret_words ++ live_words
where ret_words =
[ (x, Occupied)
- | x <- [ 1 .. toWords dflags ret_off] ]
+ | x <- [ 1 .. toWords platform ret_off] ]
live_words =
- [ (toWords dflags x, Occupied)
+ [ (toWords platform x, Occupied)
| (r,off) <- nonDetEltsUFM regs1,
-- See Note [Unique Determinism and code generation]
- let w = localRegBytes dflags r,
- x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
+ let w = localRegBytes platform r,
+ x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ]
in
-- Pass over the stack: find slots to save all the new live variables,
-- choosing the oldest slots first (hence a foldr).
let
save slot ([], stack, n, assigs, regs) -- no more regs to save
- = ([], slot:stack, plusW dflags n 1, assigs, regs)
+ = ([], slot:stack, plusW platform n 1, assigs, regs)
save slot (to_save, stack, n, assigs, regs)
= case slot of
- Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
+ Occupied -> (to_save, Occupied:stack, plusW platform n 1, assigs, regs)
Empty
| Just (stack', r, to_save') <-
select_save to_save (slot:stack)
-> let assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
- n' = plusW dflags n 1
+ n' = plusW platform n 1
in
(to_save', stack', n', assig : assigs, (r,(r,n')):regs)
| otherwise
- -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
+ -> (to_save, slot:stack, plusW platform n 1, assigs, regs)
-- we should do better here: right now we'll fit the smallest first,
-- but it would make more sense to fit the biggest first.
@@ -770,7 +772,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
= Just (replicate words Occupied ++ rest, r, rs++no_fit)
| otherwise
= go rs (r:no_fit)
- where words = localRegWords dflags r
+ where words = localRegWords platform r
-- fill in empty slots as much as possible
(still_to_save, save_stack, n, save_assigs, save_regs)
@@ -783,14 +785,14 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
push r (n, assigs, regs)
= (n', assig : assigs, (r,(r,n')) : regs)
where
- n' = n + localRegBytes dflags r
+ n' = n + localRegBytes platform r
assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
trim_sp
| not (null push_regs) = push_sp
| otherwise
- = plusW dflags n (- length (takeWhile isEmpty save_stack))
+ = plusW platform n (- length (takeWhile isEmpty save_stack))
final_regs = regs1 `addListToUFM` push_regs
`addListToUFM` save_regs
@@ -799,7 +801,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- XXX should be an assert
if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
- if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+ if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, push_assigs ++ save_assigs )
@@ -838,10 +840,11 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
+ platform = targetPlatform dflags
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
- adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
- adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+ adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off)
+ adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off)
final_middle = maybeAddSpAdj dflags sp0 sp_off
. blockFromList
@@ -867,9 +870,10 @@ maybeAddSpAdj
maybeAddSpAdj dflags sp0 sp_off block =
add_initial_unwind $ add_adj_unwind $ adj block
where
+ platform = targetPlatform dflags
adj block
| sp_off /= 0
- = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+ = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)
| otherwise = block
-- Add unwind pseudo-instruction at the beginning of each block to
-- document Sp level for debugging
@@ -878,7 +882,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)
-- Add unwind pseudo-instruction right after the Sp adjustment
-- if there is one.
@@ -888,7 +892,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)
{- Note [SP old/young offsets]
@@ -908,23 +912,23 @@ arguments.
to be Sp + Sp(L) - Sp(L')
-}
-areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
- = cmmOffset dflags spExpr (sp_old - area_off area - n)
+areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)
+ = cmmOffset platform spExpr (sp_old - area_off area - n)
-- Replace (CmmStackSlot area n) with an offset from Sp
-areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
- = mkIntExpr dflags sp_hwm
+areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)
+ = mkIntExpr platform sp_hwm
-- Replace CmmHighStackMark with the number of bytes of stack used,
-- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args)
| falseStackCheck args
- = zeroExpr dflags
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
+ = zeroExpr platform
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args)
| falseStackCheck args
- = mkIntExpr dflags 1
+ = mkIntExpr platform 1
-- Replace a stack-overflow test that cannot fail with a no-op
-- See Note [Always false stack check]
@@ -1004,8 +1008,8 @@ elimStackStores stackmap stackmaps area_off nodes
-- Update info tables to include stack liveness
-setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
@@ -1016,18 +1020,18 @@ setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
- Just sm -> stackMapToLiveness dflags sm
+ Just sm -> stackMapToLiveness platform sm
setInfoTableStackMap _ _ d = d
-stackMapToLiveness :: DynFlags -> StackMap -> Liveness
-stackMapToLiveness dflags StackMap{..} =
+stackMapToLiveness :: Platform -> StackMap -> Liveness
+stackMapToLiveness platform StackMap{..} =
reverse $ Array.elems $
- accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
- toWords dflags (sm_sp - sm_args)) live_words
+ accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1,
+ toWords platform (sm_sp - sm_args)) live_words
where
- live_words = [ (toWords dflags off, False)
+ live_words = [ (toWords platform off, False)
| (r,off) <- nonDetEltsUFM sm_regs
, isGcPtrType (localRegType r) ]
-- See Note [Unique Determinism and code generation]
@@ -1050,6 +1054,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
let entry_label = entryLabel e_node
+ platform = targetPlatform dflags
stackmap = case mapLookup entry_label final_stackmaps of
Just sm -> sm
Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
@@ -1066,7 +1071,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
-- to a proc point.
(middle1, live_with_reloads)
| entry_label `setMember` procpoints
- = let reloads = insertReloads dflags stackmap live_at_middle0
+ = let reloads = insertReloads platform stackmap live_at_middle0
in (foldr blockCons middle0 reloads, emptyRegSet)
| otherwise
= (middle0, live_at_middle0)
@@ -1076,12 +1081,12 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
return (BlockCC e_node middle1 x_node, fact_base2)
-insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
-insertReloads dflags stackmap live =
+insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
+insertReloads platform stackmap live =
[ CmmAssign (CmmLocal reg)
-- This cmmOffset basically corresponds to manifesting
-- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
- (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
+ (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))
(localRegType reg))
| (reg, reg_off) <- stackSlotRegs stackmap
, reg `elemRegSet` live
@@ -1131,16 +1136,17 @@ lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
+ let platform = targetPlatform dflags
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
- id <- newTemp (bWord dflags)
- new_base <- newTemp (cmmRegType dflags baseReg)
+ id <- newTemp (bWord platform)
+ new_base <- newTemp (cmmRegType platform baseReg)
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
save_state_code <- saveThreadState dflags
load_state_code <- loadThreadState dflags
let suspend = save_state_code <*>
caller_save <*>
- mkMiddle (callSuspendThread dflags id intrbl)
+ mkMiddle (callSuspendThread platform id intrbl)
midCall = mkUnsafeCall tgt res args
resume = mkMiddle (callResumeThread new_base id) <*>
-- Assign the result to BaseReg: we
@@ -1160,10 +1166,10 @@ lowerSafeForeignCall dflags block
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = entryCode dflags $
- CmmLoad spExpr (bWord dflags)
+ CmmLoad spExpr (bWord platform)
, cml_cont = Just succ
, cml_args_regs = regs
- , cml_args = widthInBytes (wordWidth dflags)
+ , cml_args = widthInBytes (wordWidth platform)
, cml_ret_args = ret_args
, cml_ret_off = ret_off }
@@ -1185,12 +1191,12 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
-callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
-callSuspendThread dflags id intrbl =
+callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread platform id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
- [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
+ [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
@@ -1201,8 +1207,8 @@ callResumeThread new_base id =
-- -----------------------------------------------------------------------------
-plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
-plusW dflags b w = b + w * wORD_SIZE dflags
+plusW :: Platform -> ByteOff -> WordOff -> ByteOff
+plusW platform b w = b + w * platformWordSizeInBytes platform
data StackSlot = Occupied | Empty
-- Occupied: a return address or part of an update frame
@@ -1220,15 +1226,15 @@ isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
-localRegBytes :: DynFlags -> LocalReg -> ByteOff
-localRegBytes dflags r
- = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
+localRegBytes :: Platform -> LocalReg -> ByteOff
+localRegBytes platform r
+ = roundUpToWords platform (widthInBytes (typeWidth (localRegType r)))
-localRegWords :: DynFlags -> LocalReg -> WordOff
-localRegWords dflags = toWords dflags . localRegBytes dflags
+localRegWords :: Platform -> LocalReg -> WordOff
+localRegWords platform = toWords platform . localRegBytes platform
-toWords :: DynFlags -> ByteOff -> WordOff
-toWords dflags x = x `quot` wORD_SIZE dflags
+toWords :: Platform -> ByteOff -> WordOff
+toWords platform x = x `quot` platformWordSizeInBytes platform
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index a6bec1f187..5386f4421d 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -13,6 +13,7 @@ module GHC.Cmm.Lint (
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
@@ -91,27 +92,27 @@ lintCmmExpr (CmmLoad expr rep) = do
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
- dflags <- getDynFlags
+ platform <- getPlatform
tys <- mapM lintCmmExpr args
- if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+ if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+ else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
lintCmmExpr (CmmRegOff reg offset)
- = do dflags <- getDynFlags
- let rep = typeWidth (cmmRegType dflags reg)
+ = do platform <- getPlatform
+ let rep = typeWidth (cmmRegType platform reg)
lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
lintCmmExpr expr =
- do dflags <- getDynFlags
- return (cmmExprType dflags expr)
+ do platform <- getPlatform
+ return (cmmExprType platform expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
- = do dflags <- getDynFlags
- return (machOpResultType dflags op tys)
+ = do platform <- getPlatform
+ return (machOpResultType platform op tys)
{-
isOffsetOp :: MachOp -> Bool
@@ -145,9 +146,9 @@ lintCmmMiddle node = case node of
CmmUnwind{} -> return ()
CmmAssign reg expr -> do
- dflags <- getDynFlags
+ platform <- getPlatform
erep <- lintCmmExpr expr
- let reg_ty = cmmRegType dflags reg
+ let reg_ty = cmmRegType platform reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
@@ -167,16 +168,16 @@ lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id
CmmCondBranch e t f _ -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget [t,f]
_ <- lintCmmExpr e
- checkCond dflags e
+ checkCond platform e
CmmSwitch e ids -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget $ switchTargetsToList ids
erep <- lintCmmExpr e
- if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+ if (erep `cmmEqType_ignoring_ptrhood` bWord platform)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
ppr e <> text " :: " <> ppr erep)
@@ -200,9 +201,9 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget (PrimTarget {}) = return ()
-checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
checkCond _ expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@ -228,6 +229,9 @@ instance Monad CmmLint where
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
+getPlatform :: CmmLint Platform
+getPlatform = targetPlatform <$> getDynFlags
+
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (\_ -> Left msg)
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index d811d4808f..f1a1e9b699 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -30,9 +30,9 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Type
import Outputable
-import GHC.Driver.Session
-----------------------------------------------------------------------------
-- MachOp
@@ -172,60 +172,60 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
, mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
, mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
- :: DynFlags -> MachOp
+ :: Platform -> MachOp
mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
, mo_32To8, mo_32To16
:: MachOp
-mo_wordAdd dflags = MO_Add (wordWidth dflags)
-mo_wordSub dflags = MO_Sub (wordWidth dflags)
-mo_wordEq dflags = MO_Eq (wordWidth dflags)
-mo_wordNe dflags = MO_Ne (wordWidth dflags)
-mo_wordMul dflags = MO_Mul (wordWidth dflags)
-mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags)
-mo_wordSRem dflags = MO_S_Rem (wordWidth dflags)
-mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags)
-mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags)
-mo_wordURem dflags = MO_U_Rem (wordWidth dflags)
-
-mo_wordSGe dflags = MO_S_Ge (wordWidth dflags)
-mo_wordSLe dflags = MO_S_Le (wordWidth dflags)
-mo_wordSGt dflags = MO_S_Gt (wordWidth dflags)
-mo_wordSLt dflags = MO_S_Lt (wordWidth dflags)
-
-mo_wordUGe dflags = MO_U_Ge (wordWidth dflags)
-mo_wordULe dflags = MO_U_Le (wordWidth dflags)
-mo_wordUGt dflags = MO_U_Gt (wordWidth dflags)
-mo_wordULt dflags = MO_U_Lt (wordWidth dflags)
-
-mo_wordAnd dflags = MO_And (wordWidth dflags)
-mo_wordOr dflags = MO_Or (wordWidth dflags)
-mo_wordXor dflags = MO_Xor (wordWidth dflags)
-mo_wordNot dflags = MO_Not (wordWidth dflags)
-mo_wordShl dflags = MO_Shl (wordWidth dflags)
-mo_wordSShr dflags = MO_S_Shr (wordWidth dflags)
-mo_wordUShr dflags = MO_U_Shr (wordWidth dflags)
-
-mo_u_8To32 = MO_UU_Conv W8 W32
-mo_s_8To32 = MO_SS_Conv W8 W32
-mo_u_16To32 = MO_UU_Conv W16 W32
-mo_s_16To32 = MO_SS_Conv W16 W32
-
-mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags)
-mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags)
-mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags)
-mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags)
-mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags)
-mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags)
-
-mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8
-mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16
-mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32
-mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64
-
-mo_32To8 = MO_UU_Conv W32 W8
-mo_32To16 = MO_UU_Conv W32 W16
+mo_wordAdd platform = MO_Add (wordWidth platform)
+mo_wordSub platform = MO_Sub (wordWidth platform)
+mo_wordEq platform = MO_Eq (wordWidth platform)
+mo_wordNe platform = MO_Ne (wordWidth platform)
+mo_wordMul platform = MO_Mul (wordWidth platform)
+mo_wordSQuot platform = MO_S_Quot (wordWidth platform)
+mo_wordSRem platform = MO_S_Rem (wordWidth platform)
+mo_wordSNeg platform = MO_S_Neg (wordWidth platform)
+mo_wordUQuot platform = MO_U_Quot (wordWidth platform)
+mo_wordURem platform = MO_U_Rem (wordWidth platform)
+
+mo_wordSGe platform = MO_S_Ge (wordWidth platform)
+mo_wordSLe platform = MO_S_Le (wordWidth platform)
+mo_wordSGt platform = MO_S_Gt (wordWidth platform)
+mo_wordSLt platform = MO_S_Lt (wordWidth platform)
+
+mo_wordUGe platform = MO_U_Ge (wordWidth platform)
+mo_wordULe platform = MO_U_Le (wordWidth platform)
+mo_wordUGt platform = MO_U_Gt (wordWidth platform)
+mo_wordULt platform = MO_U_Lt (wordWidth platform)
+
+mo_wordAnd platform = MO_And (wordWidth platform)
+mo_wordOr platform = MO_Or (wordWidth platform)
+mo_wordXor platform = MO_Xor (wordWidth platform)
+mo_wordNot platform = MO_Not (wordWidth platform)
+mo_wordShl platform = MO_Shl (wordWidth platform)
+mo_wordSShr platform = MO_S_Shr (wordWidth platform)
+mo_wordUShr platform = MO_U_Shr (wordWidth platform)
+
+mo_u_8To32 = MO_UU_Conv W8 W32
+mo_s_8To32 = MO_SS_Conv W8 W32
+mo_u_16To32 = MO_UU_Conv W16 W32
+mo_s_16To32 = MO_SS_Conv W16 W32
+
+mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform)
+mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform)
+mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform)
+mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform)
+mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform)
+mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform)
+
+mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8
+mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16
+mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32
+mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64
+
+mo_32To8 = MO_UU_Conv W32 W8
+mo_32To16 = MO_UU_Conv W32 W16
-- ----------------------------------------------------------------------------
@@ -365,8 +365,8 @@ maybeInvertComparison op
{- |
Returns the MachRep of the result of a MachOp.
-}
-machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
-machOpResultType dflags mop tys =
+machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType
+machOpResultType platform mop tys =
case mop of
MO_Add {} -> ty1 -- Preserve GC-ptr-hood
MO_Sub {} -> ty1 -- of first arg
@@ -379,29 +379,29 @@ machOpResultType dflags mop tys =
MO_U_Quot r -> cmmBits r
MO_U_Rem r -> cmmBits r
- MO_Eq {} -> comparisonResultRep dflags
- MO_Ne {} -> comparisonResultRep dflags
- MO_S_Ge {} -> comparisonResultRep dflags
- MO_S_Le {} -> comparisonResultRep dflags
- MO_S_Gt {} -> comparisonResultRep dflags
- MO_S_Lt {} -> comparisonResultRep dflags
+ MO_Eq {} -> comparisonResultRep platform
+ MO_Ne {} -> comparisonResultRep platform
+ MO_S_Ge {} -> comparisonResultRep platform
+ MO_S_Le {} -> comparisonResultRep platform
+ MO_S_Gt {} -> comparisonResultRep platform
+ MO_S_Lt {} -> comparisonResultRep platform
- MO_U_Ge {} -> comparisonResultRep dflags
- MO_U_Le {} -> comparisonResultRep dflags
- MO_U_Gt {} -> comparisonResultRep dflags
- MO_U_Lt {} -> comparisonResultRep dflags
+ MO_U_Ge {} -> comparisonResultRep platform
+ MO_U_Le {} -> comparisonResultRep platform
+ MO_U_Gt {} -> comparisonResultRep platform
+ MO_U_Lt {} -> comparisonResultRep platform
MO_F_Add r -> cmmFloat r
MO_F_Sub r -> cmmFloat r
MO_F_Mul r -> cmmFloat r
MO_F_Quot r -> cmmFloat r
MO_F_Neg r -> cmmFloat r
- MO_F_Eq {} -> comparisonResultRep dflags
- MO_F_Ne {} -> comparisonResultRep dflags
- MO_F_Ge {} -> comparisonResultRep dflags
- MO_F_Le {} -> comparisonResultRep dflags
- MO_F_Gt {} -> comparisonResultRep dflags
- MO_F_Lt {} -> comparisonResultRep dflags
+ MO_F_Eq {} -> comparisonResultRep platform
+ MO_F_Ne {} -> comparisonResultRep platform
+ MO_F_Ge {} -> comparisonResultRep platform
+ MO_F_Le {} -> comparisonResultRep platform
+ MO_F_Gt {} -> comparisonResultRep platform
+ MO_F_Lt {} -> comparisonResultRep platform
MO_And {} -> ty1 -- Used for pointer masking
MO_Or {} -> ty1
@@ -445,7 +445,7 @@ machOpResultType dflags mop tys =
where
(ty1:_) = tys
-comparisonResultRep :: DynFlags -> CmmType
+comparisonResultRep :: Platform -> CmmType
comparisonResultRep = bWord -- is it?
@@ -457,8 +457,8 @@ comparisonResultRep = bWord -- is it?
-- its arguments are the same as the MachOp expects. This is used when
-- linting a CmmExpr.
-machOpArgReps :: DynFlags -> MachOp -> [Width]
-machOpArgReps dflags op =
+machOpArgReps :: Platform -> MachOp -> [Width]
+machOpArgReps platform op =
case op of
MO_Add r -> [r,r]
MO_Sub r -> [r,r]
@@ -499,9 +499,9 @@ machOpArgReps dflags op =
MO_Or r -> [r,r]
MO_Xor r -> [r,r]
MO_Not r -> [r]
- MO_Shl r -> [r, wordWidth dflags]
- MO_U_Shr r -> [r, wordWidth dflags]
- MO_S_Shr r -> [r, wordWidth dflags]
+ MO_Shl r -> [r, wordWidth platform]
+ MO_U_Shr r -> [r, wordWidth platform]
+ MO_S_Shr r -> [r, wordWidth platform]
MO_SS_Conv from _ -> [from]
MO_UU_Conv from _ -> [from]
@@ -510,8 +510,8 @@ machOpArgReps dflags op =
MO_FS_Conv from _ -> [from]
MO_FF_Conv from _ -> [from]
- MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]
- MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]
+ MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]
+ MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform]
MO_V_Add _ r -> [r,r]
MO_V_Sub _ r -> [r,r]
@@ -524,8 +524,8 @@ machOpArgReps dflags op =
MO_VU_Quot _ r -> [r,r]
MO_VU_Rem _ r -> [r,r]
- MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
- MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
+ MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]
+ MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]
MO_VF_Add _ r -> [r,r]
MO_VF_Sub _ r -> [r,r]
diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs
index 7dd43852a6..a217f71c47 100644
--- a/compiler/GHC/Cmm/Opt.hs
+++ b/compiler/GHC/Cmm/Opt.hs
@@ -17,7 +17,6 @@ import GhcPrelude
import GHC.Cmm.Utils
import GHC.Cmm
-import GHC.Driver.Session
import Util
import Outputable
@@ -27,12 +26,12 @@ import Data.Bits
import Data.Maybe
-constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
-constantFoldNode dflags = mapExp (constantFoldExpr dflags)
+constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
+constantFoldNode platform = mapExp (constantFoldExpr platform)
-constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
-constantFoldExpr dflags = wrapRecExp f
- where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
+constantFoldExpr platform = wrapRecExp f
+ where f (CmmMachOp op args) = cmmMachOpFold platform op args
f (CmmRegOff r 0) = CmmReg r
f e = e
@@ -43,17 +42,17 @@ constantFoldExpr dflags = wrapRecExp f
-- been optimized and folded.
cmmMachOpFold
- :: DynFlags
+ :: Platform
-> MachOp -- The operation from an CmmMachOp
-> [CmmExpr] -- The optimized arguments
-> CmmExpr
-cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
+cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
- :: DynFlags
+ :: Platform
-> MachOp
-> [CmmExpr]
-> Maybe CmmExpr
@@ -79,7 +78,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
-cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
+cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
| Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
Just (_, rep3,signed2) <- isIntConversion conv_outer
= case () of
@@ -89,13 +88,13 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but remember to use the signedness from the widening, just in case
-- the final conversion is a widen.
| rep1 < rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested widenings: collapse if the signedness is the same
| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested narrowings: collapse
| rep1 > rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]
| otherwise ->
Nothing
where
@@ -112,22 +111,22 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?
-cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
-- for comparisons: don't forget to narrow the arguments before
-- comparing, since they might be out of range.
- MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
- MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
+ MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))
+ MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))
- MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags))
- MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
- MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags))
- MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth platform))
+ MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))
+ MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth platform))
+ MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))
- MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags))
- MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
- MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags))
- MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth platform))
+ MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))
+ MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform))
+ MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))
MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
@@ -159,9 +158,9 @@ cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-- also assume that constants have been shifted to the right when
-- possible.
-cmmMachOpFoldM dflags op [x@(CmmLit _), y]
+cmmMachOpFoldM platform op [x@(CmmLit _), y]
| not (isLit y) && isCommutableMachOp op
- = Just (cmmMachOpFold dflags op [y, x])
+ = Just (cmmMachOpFold platform op [y, x])
-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
-- moved to the right, it is more likely that we will find
@@ -179,19 +178,19 @@ cmmMachOpFoldM dflags op [x@(CmmLit _), y]
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
-cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
| mop2 `associates_with` mop1
&& not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
+ = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])
where
MO_Add{} `associates_with` MO_Sub{} = True
mop1 `associates_with` mop2 =
mop1 == mop2 && isAssociativeMachOp mop1
-- special case: (a - b) + c ==> a + (c - b)
-cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
| not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
+ = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])
-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N)
--
@@ -234,9 +233,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
-- narrowing throws away bits from the operand, there's no way to do
-- the same comparison at the larger size.
-cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
| -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
- platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
+ platformArch platform `elem` [ArchX86, ArchX86_64],
-- if the operand is widened:
Just (rep, signed, narrow_fn) <- maybe_conversion conv,
-- and this is a comparison operation:
@@ -244,7 +243,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- and the literal fits in the smaller size:
i == narrow_fn rep i
-- then we can do the comparison at the smaller size
- = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
+ = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])
where
maybe_conversion (MO_UU_Conv from to)
| to > from
@@ -278,7 +277,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- We can often do something with constants of 0 and 1 ...
-- See Note [Comparison operators]
-cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]
= case mop of
-- Arithmetic
MO_Add _ -> Just x -- x + 0 = x
@@ -310,10 +309,10 @@ cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x'
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]
= case mop of
-- Arithmetic: x*1 = x, etc
MO_Mul _ -> Just x
@@ -336,27 +335,27 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
MO_S_Ge _ | isComparisonExpr x -> Just x
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-- Now look for multiplication/division by powers of 2 (integers).
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
= case mop of
MO_Mul rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
MO_U_Quot rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
MO_U_Rem rep
| Just _ <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+ Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
MO_S_Quot rep
| Just p <- exactLog2 n,
CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require
-- it is a reg. FIXME: remove this restriction.
- Just (cmmMachOpFold dflags (MO_S_Shr rep)
+ Just (cmmMachOpFold platform (MO_S_Shr rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
MO_S_Rem rep
| Just p <- exactLog2 n,
@@ -365,8 +364,8 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
-- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
-- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
-- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
- Just (cmmMachOpFold dflags (MO_Sub rep)
- [x, cmmMachOpFold dflags (MO_And rep)
+ Just (cmmMachOpFold platform (MO_Sub rep)
+ [x, cmmMachOpFold platform (MO_And rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
_ -> Nothing
where
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 95edf0693a..8609ca4a3a 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -770,7 +770,7 @@ expr0 :: { CmmParse CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
- : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags }
+ : {- empty -} {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }
| '::' type { $2 }
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
@@ -859,7 +859,7 @@ typenot8 :: { CmmType }
| 'bits512' { b512 }
| 'float32' { f32 }
| 'float64' { f64 }
- | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
+ | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }
{
section :: String -> SectionType
@@ -880,8 +880,9 @@ mkString s = CmmString (BS8.pack s)
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
mkMachOp fn args = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
arg_exprs <- sequence args
- return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
+ return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
@@ -1147,7 +1148,8 @@ reserveStackFrame psize preg body = do
old_updfr_off <- getUpdFrameOff
reg <- preg
esize <- psize
- let size = case constantFoldExpr dflags esize of
+ 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)
@@ -1205,7 +1207,8 @@ mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
- (gcWord dflags))
+ (gcWord platform))
+ platform = targetPlatform dflags
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
@@ -1240,10 +1243,11 @@ adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-- 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
- | platformOS (targetPlatform dflags) == OSMinGW32
+ | platformOS platform == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+ where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType platform e)))
-- c.f. CgForeignCall.emitForeignCall
+ platform = targetPlatform dflags
adjCallTarget _ _ expr _
= expr
@@ -1271,8 +1275,9 @@ doStore rep addr_code val_code
-- mismatch to be flagged by cmm-lint. If we don't do this, then
-- the store will happen at the wrong type, and the error will not
-- be noticed.
- let val_width = typeWidth (cmmExprType dflags val)
+ let val_width = typeWidth (cmmExprType platform val)
rep_width = typeWidth rep
+ platform = targetPlatform dflags
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
| otherwise = val
@@ -1402,10 +1407,11 @@ forkLabelledCode p = do
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader",
- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),
( fsLit "SIZEOF_StgInfoTable",
- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))
]
+ where platform = targetPlatform dflags
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index 88db550d8a..a2d47b3d48 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -138,7 +138,7 @@ cpsTop hsc_env proc =
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
- return $ map (setInfoTableStackMap dflags stackmaps) g
+ return $ map (setInfoTableStackMap platform stackmaps) g
dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
----------- Control-flow optimisations -----------------------------
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index 9f02cdcace..324fc8f1b1 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -42,6 +42,8 @@ where
import GhcPrelude hiding (succ)
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
@@ -67,7 +69,8 @@ instance Outputable CmmTopInfo where
instance Outputable (CmmNode e x) where
- ppr = pprNode
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprNode (targetPlatform dflags) e
instance Outputable Convention where
ppr = pprConvention
@@ -177,8 +180,8 @@ pprForeignTarget (PrimTarget op)
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction))
-pprNode :: CmmNode e x -> SDoc
-pprNode node = pp_node <+> pp_debug
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
where
pp_node :: SDoc
pp_node = case node of
@@ -209,8 +212,7 @@ pprNode node = pp_node <+> pp_debug
-- rep[lv] = expr;
CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
where
- rep = sdocWithDynFlags $ \dflags ->
- ppr ( cmmExprType dflags expr )
+ rep = ppr ( cmmExprType platform expr )
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index 6c19d5f7a6..6bece6dca8 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -40,6 +40,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Ppr.Expr
import GHC.Cmm
@@ -76,7 +77,8 @@ instance Outputable RawCmmStatics where
ppr = pprRawStatics
instance Outputable CmmStatic where
- ppr = pprStatic
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprStatic (targetPlatform dflags) e
instance Outputable CmmInfoTable where
ppr = pprInfoTable
@@ -148,9 +150,9 @@ pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds)
pprRawStatics :: RawCmmStatics -> SDoc
pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
- CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
+ CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index fbd4cdb7f1..9e25ededf6 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -41,6 +41,8 @@ where
import GhcPrelude
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
import GHC.Cmm.Expr
import Outputable
@@ -51,13 +53,15 @@ import Numeric ( fromRat )
-----------------------------------------------------------------------------
instance Outputable CmmExpr where
- ppr e = pprExpr e
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprExpr (targetPlatform dflags) e
instance Outputable CmmReg where
ppr e = pprReg e
instance Outputable CmmLit where
- ppr l = pprLit l
+ ppr l = sdocWithDynFlags $ \dflags ->
+ pprLit (targetPlatform dflags) l
instance Outputable LocalReg where
ppr e = pprLocalReg e
@@ -72,16 +76,15 @@ instance Outputable GlobalReg where
-- Expressions
--
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
- = sdocWithDynFlags $ \dflags ->
- case e of
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e
+ = case e of
CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
+ pprExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType dflags reg)
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
+ where rep = typeWidth (cmmRegType platform reg)
+ CmmLit lit -> pprLit platform lit
+ _other -> pprExpr1 platform e
-- Here's the precedence table from GHC.Cmm.Parser:
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
@@ -97,10 +100,11 @@ pprExpr e
-- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
+pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc
+pprExpr1 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp1 op
+ = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
+pprExpr1 platform e = pprExpr7 platform e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
@@ -115,55 +119,57 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<')
infixMachOp1 _ = Nothing
-- %left '-' '+'
-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp7 op
+ = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
+pprExpr7 platform e = pprExpr8 platform e
infixMachOp7 (MO_Add _) = Just (char '+')
infixMachOp7 (MO_Sub _) = Just (char '-')
infixMachOp7 _ = Nothing
-- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
+pprExpr8 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp8 op
+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
+pprExpr8 platform e = pprExpr9 platform e
infixMachOp8 (MO_U_Quot _) = Just (char '/')
infixMachOp8 (MO_Mul _) = Just (char '*')
infixMachOp8 (MO_U_Rem _) = Just (char '%')
infixMachOp8 _ = Nothing
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
+pprExpr9 :: Platform -> CmmExpr -> SDoc
+pprExpr9 platform e =
case e of
- CmmLit lit -> pprLit1 lit
+ CmmLit lit -> pprLit1 platform lit
CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp mop args
+ CmmMachOp mop args -> genMachOp platform mop args
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform mop args
| Just doc <- infixMachOp mop = case args of
-- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+ [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
-- unary
- [x] -> doc <> pprExpr9 x
+ [x] -> doc <> pprExpr9 platform x
_ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"
(pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))
empty
| isJust (infixMachOp1 mop)
|| isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
- | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
(show mop))
-- replace spaces in (show mop) with underscores,
@@ -187,16 +193,15 @@ infixMachOp mop
-- To minimise line noise we adopt the convention that if the literal
-- has the natural machine word size, we do not append the type
--
-pprLit :: CmmLit -> SDoc
-pprLit lit = sdocWithDynFlags $ \dflags ->
- case lit of
+pprLit :: Platform -> CmmLit -> SDoc
+pprLit platform lit = case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth dflags) $
+ , ppUnless (rep == wordWidth platform) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
- CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>'
+ CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
CmmLabel clbl -> ppr clbl
CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
@@ -204,9 +209,9 @@ pprLit lit = sdocWithDynFlags $ \dflags ->
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
+pprLit1 platform lit = pprLit platform lit
ppr_offset :: Int -> SDoc
ppr_offset i
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index ceb4f874ee..5dd7fac1d0 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -14,8 +14,8 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Platform.Regs
-import GHC.Platform (isARM, platformArch)
+import GHC.Platform
import GHC.Driver.Session
import Unique
import UniqFM
@@ -181,6 +181,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- pprTrace "sink" (ppr lbl) $
blockJoin first final_middle final_last : sink sunk' bs
where
+ platform = targetPlatform dflags
lbl = entryLabel b
(first, middle, last) = blockSplit b
@@ -195,7 +196,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- Now sink and inline in this block
(middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
- fold_last = constantFoldNode dflags last
+ fold_last = constantFoldNode platform last
(final_last, assigs') = tryToInline dflags live fold_last assigs
-- We cannot sink into join points (successors with more than
@@ -330,12 +331,13 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
where
go [] block as = (block, as)
go ((live,node):ns) block as
- | shouldDiscard node live = go ns block as
+ | shouldDiscard node live = go ns block as
-- discard dead assignment
- | Just a <- shouldSink dflags node2 = go ns block (a : as1)
- | otherwise = go ns block' as'
+ | Just a <- shouldSink platform node2 = go ns block (a : as1)
+ | otherwise = go ns block' as'
where
- node1 = constantFoldNode dflags node
+ platform = targetPlatform dflags
+ node1 = constantFoldNode platform node
(node2, as1) = tryToInline dflags live node1 as
@@ -351,8 +353,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
-shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
-shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
+shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
+shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e)
where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
shouldSink _ _other = Nothing
@@ -430,6 +432,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
| isTrivial dflags rhs = inline_and_keep
| otherwise = dont_inline
where
+ platform = targetPlatform dflags
inline_and_discard = go usages' inl_node skipped rest
where usages' = foldLocalRegsUsed dflags addUsage usages rhs
@@ -462,9 +465,9 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
-- inl_exp is where the inlining actually takes place!
inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs
inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
- = cmmOffset dflags rhs off
+ = cmmOffset platform rhs off
-- re-constant fold after inlining
- inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+ inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args
inl_exp other = other
@@ -588,7 +591,7 @@ conflicts dflags (r, rhs, addr) node
-- (3) a store to an address conflicts with a read of the same memory
| CmmStore addr' e <- node
- , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+ , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True
-- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
| HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True
@@ -603,19 +606,21 @@ conflicts dflags (r, rhs, addr) node
-- (7) otherwise, no conflict
| otherwise = False
+ where
+ platform = targetPlatform dflags
-- Returns True if node defines any global registers that are used in the
-- Cmm expression
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)
False node
-- Returns True if node defines any local registers that are used in the
-- Cmm expression
localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr)
False node
-- Note [Sinking and calls]
@@ -745,24 +750,24 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2)
| otherwise = o2 + w2 > o1
memConflicts _ _ = True
-exprMem :: DynFlags -> CmmExpr -> AbsMem
-exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
-exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es)
-exprMem _ _ = NoMem
+exprMem :: Platform -> CmmExpr -> AbsMem
+exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
+exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)
+exprMem _ _ = NoMem
-loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
-loadAddr dflags e w =
+loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
+loadAddr platform e w =
case e of
- CmmReg r -> regAddr dflags r 0 w
- CmmRegOff r i -> regAddr dflags r i w
- _other | regUsedIn dflags spReg e -> StackMem
- | otherwise -> AnyMem
+ CmmReg r -> regAddr platform r 0 w
+ CmmRegOff r i -> regAddr platform r i w
+ _other | regUsedIn platform spReg e -> StackMem
+ | otherwise -> AnyMem
-regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
regAddr _ (CmmGlobal Hp) _ _ = HeapMem
regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
-regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself
regAddr _ _ _ _ = AnyMem
{-
diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs
index 2074c465ad..7df32dd2e8 100644
--- a/compiler/GHC/Cmm/Switch/Implement.hs
+++ b/compiler/GHC/Cmm/Switch/Implement.hs
@@ -6,6 +6,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.BlockId
import GHC.Cmm
@@ -36,18 +37,18 @@ cmmImplementSwitchPlans dflags g
-- Switch generation done by backend (LLVM/C)
| targetSupportsSwitch (hscTarget dflags) = return g
| otherwise = do
- blocks' <- concatMapM (visitSwitches dflags) (toBlockList g)
+ blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
-visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
-visitSwitches dflags block
+visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches platform block
| (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block
= do
let plan = createSwitchPlan ids
-- See Note [Floating switch expressions]
- (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr
+ (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr
- (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan
+ (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan
let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail
@@ -71,16 +72,16 @@ visitSwitches dflags block
-- This happened in parts of the handwritten RTS Cmm code. See also #16933
-- See Note [Floating switch expressions]
-floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
-floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
-floatSwitchExpr dflags expr = do
- (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM
+floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
+floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
+floatSwitchExpr platform expr = do
+ (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM
return (BMiddle assign, expr')
-- Implementing a switch plan (returning a tail block)
-implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
-implementSwitchPlan dflags scope expr = go
+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan platform scope expr = go
where
go (Unconditionally l)
= return (emptyBlock `blockJoinTail` CmmBranch l, [])
@@ -93,7 +94,7 @@ implementSwitchPlan dflags scope expr = go
let lt | signed = cmmSLtWord
| otherwise = cmmULtWord
- scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
+ scrut = lt platform expr $ CmmLit $ mkWordCLit platform i
lastNode = CmmCondBranch scrut bid1 bid2 Nothing
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks1++newBlocks2)
@@ -101,7 +102,7 @@ implementSwitchPlan dflags scope expr = go
= do
(bid2, newBlocks2) <- go' ids2
- let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
+ let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i
lastNode = CmmCondBranch scrut bid2 l Nothing
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks2)
diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs
index 2fb4ea61a7..fced2bf076 100644
--- a/compiler/GHC/Cmm/Type.hs
+++ b/compiler/GHC/Cmm/Type.hs
@@ -31,6 +31,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Driver.Session
import FastString
import Outputable
@@ -120,14 +121,14 @@ f32 = cmmFloat W32
f64 = cmmFloat W64
-- CmmTypes of native word widths
-bWord :: DynFlags -> CmmType
-bWord dflags = cmmBits (wordWidth dflags)
+bWord :: Platform -> CmmType
+bWord platform = cmmBits (wordWidth platform)
-bHalfWord :: DynFlags -> CmmType
-bHalfWord dflags = cmmBits (halfWordWidth dflags)
+bHalfWord :: Platform -> CmmType
+bHalfWord platform = cmmBits (halfWordWidth platform)
-gcWord :: DynFlags -> CmmType
-gcWord dflags = CmmType GcPtrCat (wordWidth dflags)
+gcWord :: Platform -> CmmType
+gcWord platform = CmmType GcPtrCat (wordWidth platform)
cInt :: DynFlags -> CmmType
cInt dflags = cmmBits (cIntWidth dflags)
@@ -179,23 +180,20 @@ mrStr = sLit . show
-------- Common Widths ------------
-wordWidth :: DynFlags -> Width
-wordWidth dflags
- | wORD_SIZE dflags == 4 = W32
- | wORD_SIZE dflags == 8 = W64
- | otherwise = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth :: DynFlags -> Width
-halfWordWidth dflags
- | wORD_SIZE dflags == 4 = W16
- | wORD_SIZE dflags == 8 = W32
- | otherwise = panic "MachOp.halfWordRep: Unknown word size"
-
-halfWordMask :: DynFlags -> Integer
-halfWordMask dflags
- | wORD_SIZE dflags == 4 = 0xFFFF
- | wORD_SIZE dflags == 8 = 0xFFFFFFFF
- | otherwise = panic "MachOp.halfWordMask: Unknown word size"
+wordWidth :: Platform -> Width
+wordWidth platform = case platformWordSize platform of
+ PW4 -> W32
+ PW8 -> W64
+
+halfWordWidth :: Platform -> Width
+halfWordWidth platform = case platformWordSize platform of
+ PW4 -> W16
+ PW8 -> W32
+
+halfWordMask :: Platform -> Integer
+halfWordMask platform = case platformWordSize platform of
+ PW4 -> 0xFFFF
+ PW8 -> 0xFFFFFFFF
-- cIntRep is the Width for a C-language 'int'
cIntWidth :: DynFlags -> Width
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 53a1f095f8..4071bda9d5 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GADTs, RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -75,6 +76,7 @@ import GhcPrelude
import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 )
+import GHC.Platform
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.BlockId
@@ -98,31 +100,33 @@ import GHC.Cmm.Dataflow.Collections
--
---------------------------------------------------
-primRepCmmType :: DynFlags -> PrimRep -> CmmType
-primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
-primRepCmmType dflags LiftedRep = gcWord dflags
-primRepCmmType dflags UnliftedRep = gcWord dflags
-primRepCmmType dflags IntRep = bWord dflags
-primRepCmmType dflags WordRep = bWord dflags
-primRepCmmType _ Int8Rep = b8
-primRepCmmType _ Word8Rep = b8
-primRepCmmType _ Int16Rep = b16
-primRepCmmType _ Word16Rep = b16
-primRepCmmType _ Int32Rep = b32
-primRepCmmType _ Word32Rep = b32
-primRepCmmType _ Int64Rep = b64
-primRepCmmType _ Word64Rep = b64
-primRepCmmType dflags AddrRep = bWord dflags
-primRepCmmType _ FloatRep = f32
-primRepCmmType _ DoubleRep = f64
-primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
-
-slotCmmType :: DynFlags -> SlotTy -> CmmType
-slotCmmType dflags PtrSlot = gcWord dflags
-slotCmmType dflags WordSlot = bWord dflags
-slotCmmType _ Word64Slot = b64
-slotCmmType _ FloatSlot = f32
-slotCmmType _ DoubleSlot = f64
+primRepCmmType :: Platform -> PrimRep -> CmmType
+primRepCmmType platform = \case
+ VoidRep -> panic "primRepCmmType:VoidRep"
+ LiftedRep -> gcWord platform
+ UnliftedRep -> gcWord platform
+ IntRep -> bWord platform
+ WordRep -> bWord platform
+ Int8Rep -> b8
+ Word8Rep -> b8
+ Int16Rep -> b16
+ Word16Rep -> b16
+ Int32Rep -> b32
+ Word32Rep -> b32
+ Int64Rep -> b64
+ Word64Rep -> b64
+ AddrRep -> bWord platform
+ FloatRep -> f32
+ DoubleRep -> f64
+ (VecRep len rep) -> vec len (primElemRepCmmType rep)
+
+slotCmmType :: Platform -> SlotTy -> CmmType
+slotCmmType platform = \case
+ PtrSlot -> gcWord platform
+ WordSlot -> bWord platform
+ Word64Slot -> b64
+ FloatSlot -> f32
+ DoubleSlot -> f64
primElemRepCmmType :: PrimElemRep -> CmmType
primElemRepCmmType Int8ElemRep = b8
@@ -136,8 +140,8 @@ primElemRepCmmType Word64ElemRep = b64
primElemRepCmmType FloatElemRep = f32
primElemRepCmmType DoubleElemRep = f64
-typeCmmType :: DynFlags -> UnaryType -> CmmType
-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
+typeCmmType :: Platform -> UnaryType -> CmmType
+typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
@@ -176,20 +180,20 @@ typeForeignHint = primRepForeignHint . typePrimRep1
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
-mkIntCLit :: DynFlags -> Int -> CmmLit
-mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
+mkIntCLit :: Platform -> Int -> CmmLit
+mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)
-mkIntExpr :: DynFlags -> Int -> CmmExpr
-mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+mkIntExpr :: Platform -> Int -> CmmExpr
+mkIntExpr platform i = CmmLit $! mkIntCLit platform i
-zeroCLit :: DynFlags -> CmmLit
-zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+zeroCLit :: Platform -> CmmLit
+zeroCLit platform = CmmInt 0 (wordWidth platform)
-zeroExpr :: DynFlags -> CmmExpr
-zeroExpr dflags = CmmLit (zeroCLit dflags)
+zeroExpr :: Platform -> CmmExpr
+zeroExpr platform = CmmLit (zeroCLit platform)
-mkWordCLit :: DynFlags -> Integer -> CmmLit
-mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+mkWordCLit :: Platform -> Integer -> CmmLit
+mkWordCLit platform wd = CmmInt wd (wordWidth platform)
mkByteStringCLit
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
@@ -218,8 +222,8 @@ mkRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
-mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+mkStgWordCLit :: Platform -> StgWord -> CmmLit
+mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
-- Make a single word literal in which the lower_half_word is
@@ -229,10 +233,11 @@ packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
-- but be careful: that's vulnerable when reversed
packHalfWordsCLit dflags lower_half_word upper_half_word
= if wORDS_BIGENDIAN dflags
- then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)
- else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))
+ then mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
+ else mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
where l = fromStgHalfWord lower_half_word
u = fromStgHalfWord upper_half_word
+ platform = targetPlatform dflags
---------------------------------------------------
--
@@ -243,26 +248,23 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
-cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- assumes base and offset have the same CmmType
-cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
-cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
-
-cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
-cmmOffset _ e 0 = e
-cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
-cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
-cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
-cmmOffset _ (CmmStackSlot area off) byte_off
- = CmmStackSlot area (off - byte_off)
+cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)
+cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]
+
+cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr
+cmmOffset _platform e 0 = e
+cmmOffset platform e byte_off = case e of
+ CmmReg reg -> cmmRegOff reg byte_off
+ CmmRegOff reg m -> cmmRegOff reg (m+byte_off)
+ CmmLit lit -> CmmLit (cmmOffsetLit lit byte_off)
+ CmmStackSlot area off -> CmmStackSlot area (off - byte_off)
-- note stack area offsets increase towards lower addresses
-cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
- = CmmMachOp (MO_Add rep)
- [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
-cmmOffset dflags expr byte_off
- = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
- where
- width = cmmExprWidth dflags expr
+ CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]
+ -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]
+ _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]
+ where width = cmmExprWidth platform e
-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
@@ -284,37 +286,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
-- | Useful for creating an index into an array, with a statically known offset.
-- The type is the element type; used for making the multiplier
-cmmIndex :: DynFlags
+cmmIndex :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> Int -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
+cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)
-- | Useful for creating an index into an array, with an unknown offset.
-cmmIndexExpr :: DynFlags
+cmmIndexExpr :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> CmmExpr -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
-cmmIndexExpr dflags width base idx =
- cmmOffsetExpr dflags base byte_off
+cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)
+cmmIndexExpr platform width base idx =
+ cmmOffsetExpr platform base byte_off
where
- idx_w = cmmExprWidth dflags idx
- byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
+ idx_w = cmmExprWidth platform idx
+ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
-cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
+cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
-cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
-cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
@@ -326,25 +328,25 @@ cmmOffsetLitB = cmmOffsetLit
-----------------------
-- The "W" variants take word offsets
-cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
-cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
+cmmOffsetExprW platform e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)
+cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off
-cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
+cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)
-cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
-cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
+cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)
-cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
+cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)
-cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
-cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
+cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)
-cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
+cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty
-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
@@ -352,39 +354,41 @@ cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
- :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
-cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
-cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
-cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
-cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
-cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
-cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
-cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
-cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
-cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
-cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
-cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
-cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
-
-cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
-cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
-
-blankWord :: DynFlags -> CmmStatic
-blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
-
-cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
-cmmToWord dflags e
+ :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord platform e1 e2 = CmmMachOp (mo_wordOr platform) [e1, e2]
+cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]
+cmmNeWord platform e1 e2 = CmmMachOp (mo_wordNe platform) [e1, e2]
+cmmEqWord platform e1 e2 = CmmMachOp (mo_wordEq platform) [e1, e2]
+cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]
+cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]
+cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]
+cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]
+cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]
+cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]
+cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]
+cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]
+cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]
+
+cmmNegate :: Platform -> CmmExpr -> CmmExpr
+cmmNegate platform = \case
+ (CmmLit (CmmInt n rep))
+ -> CmmLit (CmmInt (-n) rep)
+ e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
+
+blankWord :: Platform -> CmmStatic
+blankWord platform = CmmUninitialised (platformWordSizeInBytes platform)
+
+cmmToWord :: Platform -> CmmExpr -> CmmExpr
+cmmToWord platform e
| w == word = e
| otherwise = CmmMachOp (MO_UU_Conv w word) [e]
where
- w = cmmExprWidth dflags e
- word = wordWidth dflags
+ w = cmmExprWidth platform e
+ word = wordWidth platform
-cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
-cmmMkAssign dflags expr uq =
- let !ty = cmmExprType dflags expr
+cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
+cmmMkAssign platform expr uq =
+ let !ty = cmmExprType platform expr
reg = (CmmLocal (LocalReg uq ty))
in (CmmAssign reg expr, CmmReg reg)
@@ -427,21 +431,24 @@ isComparisonExpr _ = False
-- Tag bits mask
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
-cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
-cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
+cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)
+cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
-- Default case
-cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
+cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)
+ where platform = targetPlatform dflags
-- Test if a closure pointer is untagged
-cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)
+ where platform = targetPlatform dflags
-- Get constructor tag, but one based.
-cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
+cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)
+ where platform = targetPlatform dflags
-----------------------------------------------------------------------------
@@ -451,10 +458,10 @@ cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
-- platform, in the sense that writing to one will clobber the
-- other. This includes the case that the two registers are the same
-- STG register. See Note [Overlapping global registers] for details.
-regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
-regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
- | Just real <- globalRegMaybe (targetPlatform dflags) g,
- Just real' <- globalRegMaybe (targetPlatform dflags) g',
+regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool
+regsOverlap platform (CmmGlobal g) (CmmGlobal g')
+ | Just real <- globalRegMaybe platform g,
+ Just real' <- globalRegMaybe platform g',
real == real'
= True
regsOverlap _ reg reg' = reg == reg'
@@ -467,12 +474,12 @@ regsOverlap _ reg reg' = reg == reg'
-- registers here, otherwise CmmSink may incorrectly reorder
-- assignments that conflict due to overlap. See #10521 and Note
-- [Overlapping global registers].
-regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
-regUsedIn dflags = regUsedIn_ where
+regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
+regUsedIn platform = regUsedIn_ where
_ `regUsedIn_` CmmLit _ = False
reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
- reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
- reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+ reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg'
+ reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
_ `regUsedIn_` CmmStackSlot _ _ = False
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 82519db084..5b1847013c 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -240,7 +240,7 @@ sparcNcgImpl dflags
= NcgImpl {
ncgConfig = config
,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
@@ -256,6 +256,7 @@ sparcNcgImpl dflags
}
where
config = initConfig dflags
+ platform = ncgPlatform config
--
-- Allocating more stack space for spilling is currently only
@@ -1189,7 +1190,8 @@ cmmExprConFold referenceKind expr = do
cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
cmmExprCon dflags (CmmMachOp mop args)
- = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
+ = cmmMachOpFold platform mop (map (cmmExprCon dflags) args)
+ where platform = targetPlatform dflags
cmmExprCon _ other = other
-- handles both PIC and non-PIC cases... a very strange mixture
@@ -1221,9 +1223,9 @@ cmmExprNative referenceKind expr = do
-> do
dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
-- need to optimize here, since it's late
- return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
+ return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
dynRef,
- (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
+ (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
]
-- On powerpc (non-PIC), it's easier to jump directly to a label than
diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs
index d4d8b55e7e..a9668133fc 100644
--- a/compiler/GHC/CmmToAsm/PIC.hs
+++ b/compiler/GHC/CmmToAsm/PIC.hs
@@ -120,10 +120,12 @@ cmmMakeDynamicReference dflags referenceKind lbl
| otherwise
= do this_mod <- getThisModule
+ let config = initConfig dflags
+ platform = ncgPlatform config
case howToAccessLabel
dflags
- (platformArch $ targetPlatform dflags)
- (platformOS $ targetPlatform dflags)
+ (platformArch platform)
+ (platformOS platform)
this_mod
referenceKind lbl of
@@ -135,11 +137,11 @@ cmmMakeDynamicReference dflags referenceKind lbl
AccessViaSymbolPtr -> do
let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
addImport symbolPtr
- return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)
+ return $ CmmLoad (cmmMakePicReference config symbolPtr) (bWord platform)
AccessDirectly -> case referenceKind of
-- for data, we might have to make some calculations:
- DataReference -> return $ cmmMakePicReference dflags lbl
+ DataReference -> return $ cmmMakePicReference config lbl
-- all currently supported processors support
-- PC-relative branch and call instructions,
-- so just jump there if it's a call or a jump
@@ -153,42 +155,44 @@ cmmMakeDynamicReference dflags referenceKind lbl
-- offset to our base register; this offset is calculated by
-- the function picRelative in the platform-dependent part below.
-cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr
-cmmMakePicReference dflags lbl
-
- -- Windows doesn't need PIC,
- -- everything gets relocated at runtime
- | OSMinGW32 <- platformOS $ targetPlatform dflags
- = CmmLit $ CmmLabel lbl
-
- | OSAIX <- platformOS $ targetPlatform dflags
- = CmmMachOp (MO_Add W32)
- [ CmmReg (CmmGlobal PicBaseReg)
- , CmmLit $ picRelative (wordWidth dflags)
- (platformArch $ targetPlatform dflags)
- (platformOS $ targetPlatform dflags)
- lbl ]
-
- -- both ABI versions default to medium code model
- | ArchPPC_64 _ <- platformArch $ targetPlatform dflags
- = CmmMachOp (MO_Add W32) -- code model medium
- [ CmmReg (CmmGlobal PicBaseReg)
- , CmmLit $ picRelative (wordWidth dflags)
- (platformArch $ targetPlatform dflags)
- (platformOS $ targetPlatform dflags)
- lbl ]
-
- | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)
- && absoluteLabel lbl
- = CmmMachOp (MO_Add (wordWidth dflags))
- [ CmmReg (CmmGlobal PicBaseReg)
- , CmmLit $ picRelative (wordWidth dflags)
- (platformArch $ targetPlatform dflags)
- (platformOS $ targetPlatform dflags)
- lbl ]
+cmmMakePicReference :: NCGConfig -> CLabel -> CmmExpr
+cmmMakePicReference config lbl
+ -- Windows doesn't need PIC,
+ -- everything gets relocated at runtime
+ | OSMinGW32 <- platformOS platform
+ = CmmLit $ CmmLabel lbl
+
+ | OSAIX <- platformOS platform
+ = CmmMachOp (MO_Add W32)
+ [ CmmReg (CmmGlobal PicBaseReg)
+ , CmmLit $ picRelative (wordWidth platform)
+ (platformArch platform)
+ (platformOS platform)
+ lbl ]
+
+ -- both ABI versions default to medium code model
+ | ArchPPC_64 _ <- platformArch platform
+ = CmmMachOp (MO_Add W32) -- code model medium
+ [ CmmReg (CmmGlobal PicBaseReg)
+ , CmmLit $ picRelative (wordWidth platform)
+ (platformArch platform)
+ (platformOS platform)
+ lbl ]
+
+ | (ncgPIC config || ncgExternalDynamicRefs config)
+ && absoluteLabel lbl
+ = CmmMachOp (MO_Add (wordWidth platform))
+ [ CmmReg (CmmGlobal PicBaseReg)
+ , CmmLit $ picRelative (wordWidth platform)
+ (platformArch platform)
+ (platformOS platform)
+ lbl ]
+
+ | otherwise
+ = CmmLit $ CmmLabel lbl
+ where
+ platform = ncgPlatform config
- | otherwise
- = CmmLit $ CmmLabel lbl
absoluteLabel :: CLabel -> Bool
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 531efdde68..d597051b54 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -33,7 +33,7 @@ import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Monad
( NatM, getNewRegNat, getNewLabelNat
, getBlockIdNat, getPicBaseNat, getNewRegPairNat
- , getPicBaseMaybeNat, getPlatform
+ , getPicBaseMaybeNat, getPlatform, initConfig
)
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
@@ -161,7 +161,7 @@ stmtToInstrs stmt = do
| target32Bit platform &&
isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
- where ty = cmmRegType dflags reg
+ where ty = cmmRegType platform reg
format = cmmTypeFormat ty
CmmStore addr src
@@ -169,7 +169,7 @@ stmtToInstrs stmt = do
| target32Bit platform &&
isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
- where ty = cmmExprType dflags src
+ where ty = cmmExprType platform src
format = cmmTypeFormat ty
CmmUnsafeForeignCall target result_regs args
@@ -240,10 +240,10 @@ jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
-mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
-mangleIndexTree dflags (CmmRegOff reg off)
+mangleIndexTree :: Platform -> CmmExpr -> CmmExpr
+mangleIndexTree platform (CmmRegOff reg off)
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
- where width = typeWidth (cmmRegType dflags reg)
+ where width = typeWidth (cmmRegType platform reg)
mangleIndexTree _ _
= panic "PPC.CodeGen.mangleIndexTree: no match"
@@ -397,67 +397,68 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 expr
- = pprPanic "iselExpr64(powerpc)" (pprExpr expr)
+ = do
+ platform <- getPlatform
+ pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)
getRegister :: CmmExpr -> NatM Register
getRegister e = do dflags <- getDynFlags
- getRegister' dflags e
+ getRegister' dflags (targetPlatform dflags) e
-getRegister' :: DynFlags -> CmmExpr -> NatM Register
+getRegister' :: DynFlags -> Platform -> CmmExpr -> NatM Register
-getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))
- | OSAIX <- platformOS (targetPlatform dflags) = do
+getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
+ | OSAIX <- platformOS platform = do
let code dst = toOL [ LD II32 dst tocAddr ]
tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
return (Any II32 code)
- | target32Bit (targetPlatform dflags) = do
- reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))
- return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))
+ | target32Bit platform = do
+ reg <- getPicBaseNat $ archWordFormat (target32Bit platform)
+ return (Fixed (archWordFormat (target32Bit platform))
reg nilOL)
| otherwise = return (Fixed II64 toc nilOL)
-getRegister' dflags (CmmReg reg)
- = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
- (getRegisterReg (targetPlatform dflags) reg) nilOL)
+getRegister' _ platform (CmmReg reg)
+ = return (Fixed (cmmTypeFormat (cmmRegType platform reg))
+ (getRegisterReg platform reg) nilOL)
-getRegister' dflags tree@(CmmRegOff _ _)
- = getRegister' dflags (mangleIndexTree dflags tree)
+getRegister' dflags platform tree@(CmmRegOff _ _)
+ = getRegister' dflags platform (mangleIndexTree platform tree)
-- for 32-bit architectures, support some 64 -> 32 bit conversions:
-- TO_W_(x), TO_W_(x >> 32)
-getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
+getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | target32Bit (targetPlatform dflags) = do
+ | target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
-getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)
+getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | target32Bit (targetPlatform dflags) = do
+ | target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
-getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
- | target32Bit (targetPlatform dflags) = do
+getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
-getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
- | target32Bit (targetPlatform dflags) = do
+getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
-getRegister' dflags (CmmLoad mem pk)
+getRegister' _ platform (CmmLoad mem pk)
| not (isWord64 pk) = do
- let platform = targetPlatform dflags
Amode addr addr_code <- getAmode D mem
let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
addr_code `snocOL` LD format dst addr
return (Any format code)
- | not (target32Bit (targetPlatform dflags)) = do
+ | not (target32Bit platform) = do
Amode addr addr_code <- getAmode DS mem
let code dst = addr_code `snocOL` LD II64 dst addr
return (Any II64 code)
@@ -465,50 +466,50 @@ getRegister' dflags (CmmLoad mem pk)
where format = cmmTypeFormat pk
-- catch simple cases of zero- or sign-extended load
-getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
-getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
-getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
-getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
-getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
-getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
-getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
-- lwa is DS-form. See Note [Power instruction format]
Amode addr addr_code <- getAmode DS mem
return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
-getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps
+getRegister' dflags platform (CmmMachOp mop [x]) -- unary MachOps
= case mop of
MO_Not rep -> triv_ucode_int rep NOT
@@ -538,19 +539,19 @@ getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps
triv_ucode_float width instr = trivialUCode (floatFormat width) instr x
conversionNop new_format expr
- = do e_code <- getRegister' dflags expr
+ = do e_code <- getRegister' dflags platform expr
return (swizzleRegisterRep e_code new_format)
clearLeft from to
= do (src1, code1) <- getSomeReg x
- let arch_fmt = intFormat (wordWidth dflags)
- arch_bits = widthInBits (wordWidth dflags)
+ let arch_fmt = intFormat (wordWidth platform)
+ arch_bits = widthInBits (wordWidth platform)
size = widthInBits from
code dst = code1 `snocOL`
CLRLI arch_fmt dst src1 (arch_bits - size)
return (Any (intFormat to) code)
-getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
+getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
= case mop of
MO_F_Eq _ -> condFltReg EQQ x y
MO_F_Ne _ -> condFltReg NE x y
@@ -654,16 +655,15 @@ getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
return (Any fmt code)
-getRegister' _ (CmmLit (CmmInt i rep))
+getRegister' _ _ (CmmLit (CmmInt i rep))
| Just imm <- makeImmediate rep True i
= let
code dst = unitOL (LI dst imm)
in
return (Any (intFormat rep) code)
-getRegister' _ (CmmLit (CmmFloat f frep)) = do
+getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
- dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
@@ -673,9 +673,9 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
-getRegister' dflags (CmmLit lit)
- | target32Bit (targetPlatform dflags)
- = let rep = cmmLitType dflags lit
+getRegister' dflags platform (CmmLit lit)
+ | target32Bit platform
+ = let rep = cmmLitType platform lit
imm = litToImm lit
code dst = toOL [
LIS dst (HA imm),
@@ -684,17 +684,16 @@ getRegister' dflags (CmmLit lit)
in return (Any (cmmTypeFormat rep) code)
| otherwise
= do lbl <- getNewLabelNat
- dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
- let rep = cmmLitType dflags lit
+ let rep = cmmLitType platform lit
format = cmmTypeFormat rep
code dst =
LDATA (Section ReadOnlyData lbl) (RawCmmStatics lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
-getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
+getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)
-- extend?Rep: wrap integer expression of type `from`
-- in a conversion to `to`
@@ -740,8 +739,8 @@ data InstrForm = D | DS
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode inf tree@(CmmRegOff _ _)
- = do dflags <- getDynFlags
- getAmode inf (mangleIndexTree dflags tree)
+ = do platform <- getPlatform
+ getAmode inf (mangleIndexTree platform tree)
getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W32 True (-i)
@@ -1706,12 +1705,13 @@ genCCall' dflags gcp target dest_regs args
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
where
- platform = targetPlatform dflags
+ config = initConfig dflags
+ platform = ncgPlatform config
uses_pic_base_implicitly = do
-- See Note [implicit register in PPC PIC code]
-- on why we claim to use PIC register here
- when (positionIndependent dflags && target32Bit platform) $ do
+ when (ncgPIC config && target32Bit platform) $ do
_ <- getPicBaseNat $ archWordFormat True
return ()
@@ -1737,7 +1737,7 @@ genCCall' dflags gcp target dest_regs args
argReps
_ -> panic "genCall': unknown calling conv."
- argReps = map (cmmExprType dflags) args
+ argReps = map (cmmExprType platform) args
(argHints, _) = foreignTargetHints target
roundTo a x | x `mod` a == 0 = x
@@ -1849,10 +1849,10 @@ genCCall' dflags gcp target dest_regs args
accumUsed
where
arg_pro
- | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]
+ | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg]
| otherwise = arg
format_pro
- | isBitsType rep = intFormat (wordWidth dflags)
+ | isBitsType rep = intFormat (wordWidth platform)
| otherwise = cmmTypeFormat rep
conv_op = case hint of
SignedHint -> MO_SS_Conv
@@ -1935,11 +1935,11 @@ genCCall' dflags gcp target dest_regs args
[dest]
| reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1)
| isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
- | isWord64 rep && target32Bit (targetPlatform dflags)
+ | isWord64 rep && target32Bit platform
-> toOL [MR (getHiVRegFromLo r_dest) r3,
MR r_dest r4]
| otherwise -> unitOL (MR r_dest r3)
- where rep = cmmRegType dflags (CmmLocal dest)
+ where rep = cmmRegType platform (CmmLocal dest)
r_dest = getRegisterReg platform (CmmLocal dest)
_ -> panic "genCCall' moveResult: Bad dest_regs"
@@ -2043,11 +2043,11 @@ genCCall' dflags gcp target dest_regs args
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
- | OSAIX <- platformOS (targetPlatform dflags)
+ | OSAIX <- platformOS platform
= do
- (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
- let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
- sha = if target32Bit $ targetPlatform dflags then 2 else 3
+ (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+ let fmt = archWordFormat $ target32Bit platform
+ sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
@@ -2060,11 +2060,11 @@ genSwitch dflags expr targets
]
return code
- | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)
+ | (ncgPIC config) || (not $ target32Bit platform)
= do
- (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
- let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
- sha = if target32Bit $ targetPlatform dflags then 2 else 3
+ (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+ let fmt = archWordFormat $ target32Bit platform
+ sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
@@ -2079,9 +2079,9 @@ genSwitch dflags expr targets
return code
| otherwise
= do
- (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
- let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
- sha = if target32Bit $ targetPlatform dflags then 2 else 3
+ (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+ let fmt = archWordFormat $ target32Bit platform
+ sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
let code = e_code `appOL` toOL [
@@ -2092,7 +2092,10 @@ genSwitch dflags expr targets
BCTR ids (Just lbl) []
]
return code
- where (offset, ids) = switchTargetsToTable targets
+ where
+ (offset, ids) = switchTargetsToTable targets
+ platform = ncgPlatform config
+ config = initConfig dflags
generateJumpTableForInstr :: NCGConfig -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index 09f390163f..a66d1c2f99 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -294,8 +294,7 @@ pprAlignForSection platform seg =
pprDataItem :: Platform -> CmmLit -> SDoc
pprDataItem platform lit
- = sdocWithDynFlags $ \dflags ->
- vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+ = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
imm = litToImm lit
archPPC_64 = not $ target32Bit platform
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
index 2580ea4014..67177ea0c6 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
@@ -36,7 +36,8 @@ import GHC.CmmToAsm.SPARC.Regs
import GHC.CmmToAsm.SPARC.Stack
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat )
+import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig )
+import GHC.CmmToAsm.Config
-- Our intermediate code:
import GHC.Cmm.BlockId
@@ -123,7 +124,8 @@ stmtsToInstrs stmts
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
- dflags <- getDynFlags
+ platform <- getPlatform
+ config <- getConfig
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
@@ -133,14 +135,14 @@ stmtToInstrs stmt = do
| isFloatType ty -> assignReg_FltCode format reg src
| isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
- where ty = cmmRegType dflags reg
+ where ty = cmmRegType platform reg
format = cmmTypeFormat ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode format addr src
| isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
- where ty = cmmExprType dflags src
+ where ty = cmmExprType platform src
format = cmmTypeFormat ty
CmmUnsafeForeignCall target result_regs args
@@ -151,8 +153,7 @@ stmtToInstrs stmt = do
b1 <- genCondJump true arg
b2 <- genBranch false
return (b1 `appOL` b2)
- CmmSwitch arg ids -> do dflags <- getDynFlags
- genSwitch dflags arg ids
+ CmmSwitch arg ids -> genSwitch config arg ids
CmmCall { cml_target = arg } -> genJump arg
_
@@ -180,8 +181,8 @@ temporary, then do the other computation, and then use the temporary:
-- | Convert a BlockId to some CmmStatic data
-jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
-jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic
+jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform))
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = blockLbl blockid
@@ -208,9 +209,9 @@ assignMem_IntCode pk addr src = do
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode _ reg src = do
- dflags <- getDynFlags
+ platform <- getPlatform
r <- getRegister src
- let dst = getRegisterReg (targetPlatform dflags) reg
+ let dst = getRegisterReg platform reg
return $ case r of
Any _ code -> code dst
Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
@@ -220,12 +221,12 @@ assignReg_IntCode _ reg src = do
-- Floating point assignment to memory
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode pk addr src = do
- dflags <- getDynFlags
+ platform <- getPlatform
Amode dst__2 code1 <- getAmode addr
(src__2, code2) <- getSomeReg src
tmp1 <- getNewRegNat pk
let
- pk__2 = cmmExprType dflags src
+ pk__2 = cmmExprType platform src
code__2 = code1 `appOL` code2 `appOL`
if formatToWidth pk == typeWidth pk__2
then unitOL (ST pk src__2 dst__2)
@@ -236,8 +237,7 @@ assignMem_FltCode pk addr src = do
-- Floating point assignment to a register/temporary
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_FltCode pk dstCmmReg srcCmmExpr = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- getPlatform
srcRegister <- getRegister srcCmmExpr
let dstReg = getRegisterReg platform dstCmmReg
@@ -309,13 +309,13 @@ genCondJump bid bool = do
-- -----------------------------------------------------------------------------
-- Generating a table-branch
-genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
-genSwitch dflags expr targets
- | positionIndependent dflags
+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch config expr targets
+ | ncgPIC config
= error "MachCodeGen: sparc genSwitch PIC not finished\n"
| otherwise
- = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)
+ = do (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset)
base_reg <- getNewRegNat II32
offset_reg <- getNewRegNat II32
@@ -338,10 +338,10 @@ genSwitch dflags expr targets
, NOP ]
where (offset, ids) = switchTargetsToTable targets
-generateJumpTableForInstr :: DynFlags -> Instr
+generateJumpTableForInstr :: Platform -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
-generateJumpTableForInstr dflags (JMP_TBL _ ids label) =
- let jumpTable = map (jumpTableEntry dflags) ids
+generateJumpTableForInstr platform (JMP_TBL _ ids label) =
+ let jumpTable = map (jumpTableEntry platform) ids
in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics label jumpTable))
generateJumpTableForInstr _ _ = Nothing
@@ -469,21 +469,21 @@ genCCall target dest_regs args
-- | Generate code to calculate an argument, and move it into one
-- or two integer vregs.
arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
-arg_to_int_vregs arg = do dflags <- getDynFlags
- arg_to_int_vregs' dflags arg
+arg_to_int_vregs arg = do platform <- getPlatform
+ arg_to_int_vregs' platform arg
-arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])
-arg_to_int_vregs' dflags arg
+arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg])
+arg_to_int_vregs' platform arg
-- If the expr produces a 64 bit int, then we can just use iselExpr64
- | isWord64 (cmmExprType dflags arg)
+ | isWord64 (cmmExprType platform arg)
= do (ChildCode64 code r_lo) <- iselExpr64 arg
let r_hi = getHiVRegFromLo r_lo
return (code, [r_hi, r_lo])
| otherwise
= do (src, code) <- getSomeReg arg
- let pk = cmmExprType dflags arg
+ let pk = cmmExprType platform arg
case cmmTypeFormat pk of
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs
index d6c9d7b360..75eba25023 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs
@@ -27,8 +27,8 @@ getAmode
-> NatM Amode
getAmode tree@(CmmRegOff _ _)
- = do dflags <- getDynFlags
- getAmode (mangleIndexTree dflags tree)
+ = do platform <- getPlatform
+ getAmode (mangleIndexTree platform tree)
getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])
| fits13Bits (-i)
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs
index cf249303e4..f00e60ca93 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs
@@ -23,7 +23,6 @@ import GHC.CmmToAsm.Format
import GHC.Platform.Reg
import GHC.Platform.Regs
-import GHC.Driver.Session
import GHC.Cmm
import GHC.Cmm.Ppr.Expr () -- For Outputable instances
import GHC.Platform
@@ -109,11 +108,11 @@ getRegisterReg platform (CmmGlobal mid)
-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
-mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
+mangleIndexTree :: Platform -> CmmExpr -> CmmExpr
-mangleIndexTree dflags (CmmRegOff reg off)
+mangleIndexTree platform (CmmRegOff reg off)
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
- where width = typeWidth (cmmRegType dflags reg)
+ where width = typeWidth (cmmRegType platform reg)
mangleIndexTree _ _
= panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs
index e501d799f2..3f8912a9c4 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs
@@ -87,15 +87,15 @@ condIntCode cond x y = do
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode cond x y = do
- dflags <- getDynFlags
+ platform <- getPlatform
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
tmp <- getNewRegNat FF64
let
promote x = FxTOy FF32 FF64 x tmp
- pk1 = cmmExprType dflags x
- pk2 = cmmExprType dflags y
+ pk1 = cmmExprType platform x
+ pk2 = cmmExprType platform y
code__2 =
if pk1 `cmmEqType` pk2 then
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs
index ee67bd4a9d..8d2c6c33f6 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs
@@ -26,7 +26,6 @@ import GHC.Platform.Reg
import GHC.Cmm
import Control.Monad (liftM)
-import GHC.Driver.Session
import OrdList
import Outputable
@@ -49,14 +48,13 @@ getSomeReg expr = do
getRegister :: CmmExpr -> NatM Register
getRegister (CmmReg reg)
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
- return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
+ = do platform <- getPlatform
+ return (Fixed (cmmTypeFormat (cmmRegType platform reg))
(getRegisterReg platform reg) nilOL)
getRegister tree@(CmmRegOff _ _)
- = do dflags <- getDynFlags
- getRegister (mangleIndexTree dflags tree)
+ = do platform <- getPlatform
+ getRegister (mangleIndexTree platform tree)
getRegister (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
@@ -483,15 +481,15 @@ trivialFCode
-> NatM Register
trivialFCode pk instr x y = do
- dflags <- getDynFlags
+ platform <- getPlatform
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
tmp <- getNewRegNat FF64
let
promote x = FxTOy FF32 FF64 x tmp
- pk1 = cmmExprType dflags x
- pk2 = cmmExprType dflags y
+ pk1 = cmmExprType platform x
+ pk2 = cmmExprType platform y
code__2 dst =
if pk1 `cmmEqType` pk2 then
diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
index fc382a5c10..566b23c1d6 100644
--- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
@@ -98,7 +98,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs)
Nothing -> empty
Just (RawCmmStatics info_lbl info) ->
pprAlignForSection Text $$
- vcat (map pprData info) $$
+ vcat (map (pprData platform) info) $$
pprLabel platform info_lbl
@@ -113,12 +113,12 @@ pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, alias `mayRedirectTo` ind'
= pprGloblDecl alias
$$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
-pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map pprData dats)
+pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
-pprData :: CmmStatic -> SDoc
-pprData (CmmString str) = pprBytes str
-pprData (CmmUninitialised bytes) = text ".skip " <> int bytes
-pprData (CmmStaticLit lit) = pprDataItem lit
+pprData :: Platform -> CmmStatic -> SDoc
+pprData _ (CmmString str) = pprBytes str
+pprData _ (CmmUninitialised bytes) = text ".skip " <> int bytes
+pprData platform (CmmStaticLit lit) = pprDataItem platform lit
pprGloblDecl :: CLabel -> SDoc
pprGloblDecl lbl
@@ -345,10 +345,9 @@ pprAlignForSection seg =
OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section")
-- | Pretty print a data item.
-pprDataItem :: CmmLit -> SDoc
-pprDataItem lit
- = sdocWithDynFlags $ \dflags ->
- vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+pprDataItem :: Platform -> CmmLit -> SDoc
+pprDataItem platform lit
+ = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
imm = litToImm lit
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 17e246366b..bf282fcac4 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -332,7 +332,6 @@ stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed
-- ^ Instructions, and bid of new block if successive
-- statements are placed in a different basic block.
stmtToInstrs bid stmt = do
- dflags <- getDynFlags
is32Bit <- is32BitPlatform
platform <- getPlatform
case stmt of
@@ -345,7 +344,7 @@ stmtToInstrs bid stmt = do
CmmUnwind regs -> do
let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
- to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)
+ to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)
case foldMap to_unwind_entry regs of
tbl | M.null tbl -> return nilOL
| otherwise -> do
@@ -356,14 +355,14 @@ stmtToInstrs bid stmt = do
| isFloatType ty -> assignReg_FltCode format reg src
| is32Bit && isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
- where ty = cmmRegType dflags reg
+ where ty = cmmRegType platform reg
format = cmmTypeFormat ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode format addr src
| is32Bit && isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
- where ty = cmmExprType dflags src
+ where ty = cmmExprType platform src
format = cmmTypeFormat ty
CmmBranch id -> return $ genBranch id
@@ -487,10 +486,10 @@ jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-- Expand CmmRegOff. ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
-mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr
-mangleIndexTree dflags reg off
+mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr
+mangleIndexTree platform reg off
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
- where width = typeWidth (cmmRegType dflags reg)
+ where width = typeWidth (cmmRegType platform reg)
-- | The dual to getAnyReg: compute an expression into a register, but
-- we don't mind which one it is.
@@ -637,13 +636,13 @@ iselExpr64 expr
--------------------------------------------------------------------------------
getRegister :: CmmExpr -> NatM Register
-getRegister e = do dflags <- getDynFlags
+getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
- getRegister' dflags is32Bit e
+ getRegister' platform is32Bit e
-getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register
+getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register
-getRegister' dflags is32Bit (CmmReg reg)
+getRegister' platform is32Bit (CmmReg reg)
= case reg of
CmmGlobal PicBaseReg
| is32Bit ->
@@ -655,7 +654,7 @@ getRegister' dflags is32Bit (CmmReg reg)
_ ->
do
let
- fmt = cmmTypeFormat (cmmRegType dflags reg)
+ fmt = cmmTypeFormat (cmmRegType platform reg)
format = fmt
--
platform <- ncgPlatform <$> getConfig
@@ -664,11 +663,11 @@ getRegister' dflags is32Bit (CmmReg reg)
nilOL)
-getRegister' dflags is32Bit (CmmRegOff r n)
- = getRegister' dflags is32Bit $ mangleIndexTree dflags r n
+getRegister' platform is32Bit (CmmRegOff r n)
+ = getRegister' platform is32Bit $ mangleIndexTree platform r n
-getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
- = addAlignmentCheck align <$> getRegister' dflags is32Bit e
+getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
+ = addAlignmentCheck align <$> getRegister' platform is32Bit e
-- for 32-bit architectures, support some 64 -> 32 bit conversions:
-- TO_W_(x), TO_W_(x >> 32)
@@ -764,7 +763,7 @@ getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
return $ Any II64 (\dst -> unitOL $
LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
-getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
+getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
case mop of
MO_F_Neg w -> sse2NegCode w x
@@ -892,7 +891,7 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop new_format expr
- = do e_code <- getRegister' dflags is32Bit expr
+ = do e_code <- getRegister' platform is32Bit expr
return (swizzleRegisterRep e_code new_format)
@@ -1165,8 +1164,8 @@ getRegister' _ is32Bit (CmmLit (CmmInt 0 width))
-- optimisation for loading small literals on x86_64: take advantage
-- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
-- instruction forms are shorter.
-getRegister' dflags is32Bit (CmmLit lit)
- | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)
+getRegister' platform is32Bit (CmmLit lit)
+ | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)
= let
imm = litToImm lit
code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
@@ -1181,8 +1180,8 @@ getRegister' dflags is32Bit (CmmLit lit)
-- note2: all labels are small, because we're assuming the
-- small memory model (see gcc docs, -mcmodel=small).
-getRegister' dflags _ (CmmLit lit)
- = do let format = cmmTypeFormat (cmmLitType dflags lit)
+getRegister' platform _ (CmmLit lit)
+ = do let format = cmmTypeFormat (cmmLitType platform lit)
imm = litToImm lit
code dst = unitOL (MOV format (OpImm imm) (OpReg dst))
return (Any format code)
@@ -1260,8 +1259,8 @@ getAmode e = do is32Bit <- is32BitPlatform
getAmode' is32Bit e
getAmode' :: Bool -> CmmExpr -> NatM Amode
-getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags
- getAmode $ mangleIndexTree dflags r n
+getAmode' _ (CmmRegOff r n) = do platform <- getPlatform
+ getAmode $ mangleIndexTree platform r n
getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
CmmLit displacement])
@@ -1361,7 +1360,7 @@ x86_complex_amode base index shift offset
getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand (CmmLit lit) = do
- if isSuitableFloatingPointLit lit
+ if isSuitableFloatingPointLit lit
then do
let CmmFloat _ w = lit
Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
@@ -1369,8 +1368,8 @@ getNonClobberedOperand (CmmLit lit) = do
else do
is32Bit <- is32BitPlatform
- dflags <- getDynFlags
- if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+ platform <- getPlatform
+ if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))
then return (OpImm (litToImm lit), nilOL)
else getNonClobberedOperand_generic (CmmLit lit)
@@ -1428,8 +1427,8 @@ getOperand (CmmLit lit) = do
else do
is32Bit <- is32BitPlatform
- dflags <- getDynFlags
- if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+ platform <- getPlatform
+ if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))
then return (OpImm (litToImm lit), nilOL)
else getOperand_generic (CmmLit lit)
@@ -1622,34 +1621,34 @@ condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
-- anything vs operand
condIntCode' is32Bit cond x y
| isOperand is32Bit y = do
- dflags <- getDynFlags
+ platform <- getPlatform
(x_reg, x_code) <- getNonClobberedReg x
(y_op, y_code) <- getOperand y
let
code = x_code `appOL` y_code `snocOL`
- CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg)
+ CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)
return (CondCode False cond code)
-- operand vs. anything: invert the comparison so that we can use a
-- single comparison instruction.
| isOperand is32Bit x
, Just revcond <- maybeFlipCond cond = do
- dflags <- getDynFlags
+ platform <- getPlatform
(y_reg, y_code) <- getNonClobberedReg y
(x_op, x_code) <- getOperand x
let
code = y_code `appOL` x_code `snocOL`
- CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg)
+ CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)
return (CondCode False revcond code)
-- anything vs anything
condIntCode' _ cond x y = do
- dflags <- getDynFlags
+ platform <- getPlatform
(y_reg, y_code) <- getNonClobberedReg y
(x_op, x_code) <- getRegOrMem x
let
code = y_code `appOL`
x_code `snocOL`
- CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op
+ CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op
return (CondCode False cond code)
@@ -1666,13 +1665,13 @@ condFltCode cond x y
-- an operand, but the right must be a reg. We can probably do better
-- than this general case...
condFltCode_sse2 = do
- dflags <- getDynFlags
+ platform <- getPlatform
(x_reg, x_code) <- getNonClobberedReg x
(y_op, y_code) <- getOperand y
let
code = x_code `appOL`
y_code `snocOL`
- CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg)
+ CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)
-- NB(1): we need to use the unsigned comparison operators on the
-- result of this comparison.
return (CondCode True (condToUnsigned cond) code)
@@ -2529,7 +2528,7 @@ genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = d
where
format = intFormat width
-genCCall' dflags is32Bit target dest_regs args bid = do
+genCCall' _ is32Bit target dest_regs args bid = do
platform <- ncgPlatform <$> getConfig
case (target, dest_regs) of
-- void return type prim op
@@ -2639,8 +2638,8 @@ genCCall' dflags is32Bit target dest_regs args bid = do
_ -> panic "genCCall: Wrong number of arguments/results for imul2"
_ -> if is32Bit
- then genCCall32' dflags target dest_regs args
- else genCCall64' dflags target dest_regs args
+ then genCCall32' target dest_regs args
+ else genCCall64' target dest_regs args
where divOp1 platform signed width results [arg_x, arg_y]
= divOp platform signed width results Nothing arg_x arg_y
@@ -2719,22 +2718,82 @@ genCCall' dflags is32Bit target dest_regs args bid = do
-- and get the results from %al, %dl. This is not optimal, but a few
-- register moves are probably not a huge deal when doing division.
-genCCall32' :: DynFlags
- -> ForeignTarget -- function to call
+genCCall32' :: ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
-> [CmmActual] -- arguments (of mixed type)
-> NatM InstrBlock
-genCCall32' dflags target dest_regs args = do
- let
- prom_args = map (maybePromoteCArg dflags W32) args
+genCCall32' target dest_regs args = do
+ config <- getConfig
+ let platform = ncgPlatform config
+ prom_args = map (maybePromoteCArg platform W32) args
+
+ -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
+ arg_size_bytes :: CmmType -> Int
+ arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))
+
+ roundTo a x | x `mod` a == 0 = x
+ | otherwise = x + a - (x `mod` a)
+ push_arg :: CmmActual {-current argument-}
+ -> NatM InstrBlock -- code
+
+ push_arg arg -- we don't need the hints on x86
+ | isWord64 arg_ty = do
+ ChildCode64 code r_lo <- iselExpr64 arg
+ delta <- getDeltaNat
+ setDeltaNat (delta - 8)
+ let r_hi = getHiVRegFromLo r_lo
+ return ( code `appOL`
+ toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
+ PUSH II32 (OpReg r_lo), DELTA (delta - 8),
+ DELTA (delta-8)]
+ )
+
+ | isFloatType arg_ty = do
+ (reg, code) <- getSomeReg arg
+ delta <- getDeltaNat
+ setDeltaNat (delta-size)
+ return (code `appOL`
+ toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
+ DELTA (delta-size),
+ let addr = AddrBaseIndex (EABaseReg esp)
+ EAIndexNone
+ (ImmInt 0)
+ format = floatFormat (typeWidth arg_ty)
+ in
+
+ -- assume SSE2
+ MOV format (OpReg reg) (OpAddr addr)
+
+ ]
+ )
+
+ | otherwise = do
+ -- Arguments can be smaller than 32-bit, but we still use @PUSH
+ -- II32@ - the usual calling conventions expect integers to be
+ -- 4-byte aligned.
+ ASSERT((typeWidth arg_ty) <= W32) return ()
+ (operand, code) <- getOperand arg
+ delta <- getDeltaNat
+ setDeltaNat (delta-size)
+ return (code `snocOL`
+ PUSH II32 operand `snocOL`
+ DELTA (delta-size))
+
+ where
+ arg_ty = cmmExprType platform arg
+ size = arg_size_bytes arg_ty -- Byte size
+
+ let
-- Align stack to 16n for calls, assuming a starting stack
-- alignment of 16n - word_size on procedure entry. Which we
-- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
- sizes = map (arg_size_bytes . cmmExprType dflags) (reverse args)
- raw_arg_size = sum sizes + wORD_SIZE dflags
+ sizes = map (arg_size_bytes . cmmExprType platform) (reverse args)
+ raw_arg_size = sum sizes + platformWordSizeInBytes platform
arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size
- tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags
+ tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform
+
+
delta0 <- getDeltaNat
setDeltaNat (delta0 - arg_pad_size)
@@ -2751,7 +2810,7 @@ genCCall32' dflags target dest_regs args = do
where fn_imm = ImmCLbl lbl
ForeignTarget expr conv
-> do { (dyn_r, dyn_c) <- getSomeReg expr
- ; ASSERT( isWord32 (cmmExprType dflags expr) )
+ ; ASSERT( isWord32 (cmmExprType platform expr) )
return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
PrimTarget _
-> panic $ "genCCall: Can't handle PrimTarget call type here, error "
@@ -2783,8 +2842,6 @@ genCCall32' dflags target dest_regs args = do
)
setDeltaNat delta0
- platform <- getPlatform
-
let
-- assign the results, if necessary
assign_code [] = nilOL
@@ -2815,198 +2872,24 @@ genCCall32' dflags target dest_regs args = do
w = typeWidth ty
b = widthInBytes w
r_dest_hi = getHiVRegFromLo r_dest
- r_dest = getRegisterReg platform (CmmLocal dest)
+ r_dest = getRegisterReg platform (CmmLocal dest)
assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)
return (push_code `appOL`
call `appOL`
assign_code dest_regs)
- where
- -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
- arg_size_bytes :: CmmType -> Int
- arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags))
-
- roundTo a x | x `mod` a == 0 = x
- | otherwise = x + a - (x `mod` a)
-
- push_arg :: CmmActual {-current argument-}
- -> NatM InstrBlock -- code
-
- push_arg arg -- we don't need the hints on x86
- | isWord64 arg_ty = do
- ChildCode64 code r_lo <- iselExpr64 arg
- delta <- getDeltaNat
- setDeltaNat (delta - 8)
- let r_hi = getHiVRegFromLo r_lo
- return ( code `appOL`
- toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
- PUSH II32 (OpReg r_lo), DELTA (delta - 8),
- DELTA (delta-8)]
- )
-
- | isFloatType arg_ty = do
- (reg, code) <- getSomeReg arg
- delta <- getDeltaNat
- setDeltaNat (delta-size)
- return (code `appOL`
- toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
- DELTA (delta-size),
- let addr = AddrBaseIndex (EABaseReg esp)
- EAIndexNone
- (ImmInt 0)
- format = floatFormat (typeWidth arg_ty)
- in
-
- -- assume SSE2
- MOV format (OpReg reg) (OpAddr addr)
-
- ]
- )
-
- | otherwise = do
- -- Arguments can be smaller than 32-bit, but we still use @PUSH
- -- II32@ - the usual calling conventions expect integers to be
- -- 4-byte aligned.
- ASSERT((typeWidth arg_ty) <= W32) return ()
- (operand, code) <- getOperand arg
- delta <- getDeltaNat
- setDeltaNat (delta-size)
- return (code `snocOL`
- PUSH II32 operand `snocOL`
- DELTA (delta-size))
-
- where
- arg_ty = cmmExprType dflags arg
- size = arg_size_bytes arg_ty -- Byte size
-
-genCCall64' :: DynFlags
- -> ForeignTarget -- function to call
+genCCall64' :: ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
-> [CmmActual] -- arguments (of mixed type)
-> NatM InstrBlock
-genCCall64' dflags target dest_regs args = do
+genCCall64' target dest_regs args = do
config <- getConfig
let platform = ncgPlatform config
-- load up the register arguments
- let prom_args = map (maybePromoteCArg dflags W32) args
-
- (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)
- <-
- if platformOS platform == OSMinGW32
- then load_args_win prom_args [] [] (allArgRegs platform) nilOL
- else do
- (stack_args, aregs, fregs, load_args_code, assign_args_code)
- <- load_args prom_args (allIntArgRegs platform)
- (allFPArgRegs platform)
- nilOL nilOL
- let used_regs rs as = reverse (drop (length rs) (reverse as))
- fregs_used = used_regs fregs (allFPArgRegs platform)
- aregs_used = used_regs aregs (allIntArgRegs platform)
- return (stack_args, aregs_used, fregs_used, load_args_code
- , assign_args_code)
-
- let
- arg_regs_used = int_regs_used ++ fp_regs_used
- arg_regs = [eax] ++ arg_regs_used
- -- for annotating the call instruction with
- sse_regs = length fp_regs_used
- arg_stack_slots = if platformOS platform == OSMinGW32
- then length stack_args + length (allArgRegs platform)
- else length stack_args
- tot_arg_size = arg_size * arg_stack_slots
-
-
- -- 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 platform
- (real_size, adjust_rsp) <-
- if (tot_arg_size + word_size) `rem` 16 == 0
- then return (tot_arg_size, nilOL)
- else do -- we need to adjust...
- delta <- getDeltaNat
- setDeltaNat (delta - word_size)
- return (tot_arg_size + word_size, toOL [
- SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),
- DELTA (delta - word_size) ])
-
- -- push the stack args, right to left
- push_code <- push_args (reverse stack_args) nilOL
- -- On Win64, we also have to leave stack space for the arguments
- -- that we are passing in registers
- lss_code <- if platformOS platform == OSMinGW32
- then leaveStackSpace (length (allArgRegs platform))
- else return nilOL
- delta <- getDeltaNat
-
- -- deal with static vs dynamic call targets
- (callinsns,_cconv) <-
- case target of
- ForeignTarget (CmmLit (CmmLabel lbl)) conv
- -> -- ToDo: stdcall arg sizes
- return (unitOL (CALL (Left fn_imm) arg_regs), conv)
- where fn_imm = ImmCLbl lbl
- ForeignTarget expr conv
- -> do (dyn_r, dyn_c) <- getSomeReg expr
- return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
- PrimTarget _
- -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
- ++ "probably because too many return values."
-
- let
- -- The x86_64 ABI requires us to set %al to the number of SSE2
- -- registers that contain arguments, if the called routine
- -- is a varargs function. We don't know whether it's a
- -- varargs function or not, so we have to assume it is.
- --
- -- It's not safe to omit this assignment, even if the number
- -- of SSE2 regs in use is zero. If %al is larger than 8
- -- on entry to a varargs function, seg faults ensue.
- assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
-
- let call = callinsns `appOL`
- toOL (
- -- Deallocate parameters after call for ccall;
- -- 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)])
- ++
- [DELTA (delta + real_size)]
- )
- setDeltaNat (delta + real_size)
-
- let
- -- assign the results, if necessary
- assign_code [] = nilOL
- assign_code [dest] =
- case typeWidth rep of
- W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)
- (OpReg xmm0)
- (OpReg r_dest))
- W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)
- (OpReg xmm0)
- (OpReg r_dest))
- _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))
- where
- rep = localRegType dest
- r_dest = getRegisterReg platform (CmmLocal dest)
- assign_code _many = panic "genCCall.assign_code many"
+ let prom_args = map (maybePromoteCArg platform W32) args
- return (adjust_rsp `appOL`
- push_code `appOL`
- load_args_code `appOL`
- assign_args_code `appOL`
- lss_code `appOL`
- assign_eax sse_regs `appOL`
- call `appOL`
- assign_code dest_regs)
-
- where arg_size = 8 -- always, at the mo
-
-
- load_args :: [CmmExpr]
+ let load_args :: [CmmExpr]
-> [Reg] -- int regs avail for args
-> [Reg] -- FP regs avail for args
-> InstrBlock -- code computing args
@@ -3064,7 +2947,7 @@ genCCall64' dflags target dest_regs args = do
acode' = acode `snocOL` reg2reg arg_fmt tmp r
return (code',acode')
- arg_rep = cmmExprType dflags arg
+ arg_rep = cmmExprType platform arg
arg_fmt = cmmTypeFormat arg_rep
load_args_win :: [CmmExpr]
@@ -3095,7 +2978,9 @@ genCCall64' dflags target dest_regs args = do
load_args_win rest (ireg : usedInt) usedFP regs
(code `appOL` arg_code ireg)
where
- arg_rep = cmmExprType dflags arg
+ arg_rep = cmmExprType platform arg
+
+ arg_size = 8 -- always, at the mo
push_args [] code = return code
push_args (arg:rest) code
@@ -3104,9 +2989,9 @@ genCCall64' dflags target dest_regs args = do
delta <- getDeltaNat
setDeltaNat (delta-arg_size)
let code' = code `appOL` arg_code `appOL` toOL [
- SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp),
+ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),
DELTA (delta-arg_size),
- MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel (targetPlatform dflags) 0))]
+ MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]
push_args rest code'
| otherwise = do
@@ -3122,22 +3007,135 @@ genCCall64' dflags target dest_regs args = do
DELTA (delta-arg_size)]
push_args rest code'
where
- arg_rep = cmmExprType dflags arg
+ arg_rep = cmmExprType platform arg
width = typeWidth arg_rep
leaveStackSpace n = do
delta <- getDeltaNat
setDeltaNat (delta - n * arg_size)
return $ toOL [
- SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp),
+ SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),
DELTA (delta - n * arg_size)]
-maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
-maybePromoteCArg dflags wto arg
+ (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)
+ <-
+ if platformOS platform == OSMinGW32
+ then load_args_win prom_args [] [] (allArgRegs platform) nilOL
+ else do
+ (stack_args, aregs, fregs, load_args_code, assign_args_code)
+ <- load_args prom_args (allIntArgRegs platform)
+ (allFPArgRegs platform)
+ nilOL nilOL
+ let used_regs rs as = reverse (drop (length rs) (reverse as))
+ fregs_used = used_regs fregs (allFPArgRegs platform)
+ aregs_used = used_regs aregs (allIntArgRegs platform)
+ return (stack_args, aregs_used, fregs_used, load_args_code
+ , assign_args_code)
+
+ let
+ arg_regs_used = int_regs_used ++ fp_regs_used
+ arg_regs = [eax] ++ arg_regs_used
+ -- for annotating the call instruction with
+ sse_regs = length fp_regs_used
+ arg_stack_slots = if platformOS platform == OSMinGW32
+ then length stack_args + length (allArgRegs platform)
+ else length stack_args
+ tot_arg_size = arg_size * arg_stack_slots
+
+
+ -- 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)
+ (real_size, adjust_rsp) <-
+ if (tot_arg_size + word_size) `rem` 16 == 0
+ then return (tot_arg_size, nilOL)
+ else do -- we need to adjust...
+ delta <- getDeltaNat
+ setDeltaNat (delta - word_size)
+ return (tot_arg_size + word_size, toOL [
+ SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),
+ DELTA (delta - word_size) ])
+
+ -- push the stack args, right to left
+ push_code <- push_args (reverse stack_args) nilOL
+ -- On Win64, we also have to leave stack space for the arguments
+ -- that we are passing in registers
+ lss_code <- if platformOS platform == OSMinGW32
+ then leaveStackSpace (length (allArgRegs platform))
+ else return nilOL
+ delta <- getDeltaNat
+
+ -- deal with static vs dynamic call targets
+ (callinsns,_cconv) <-
+ case target of
+ ForeignTarget (CmmLit (CmmLabel lbl)) conv
+ -> -- ToDo: stdcall arg sizes
+ return (unitOL (CALL (Left fn_imm) arg_regs), conv)
+ where fn_imm = ImmCLbl lbl
+ ForeignTarget expr conv
+ -> do (dyn_r, dyn_c) <- getSomeReg expr
+ return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
+ PrimTarget _
+ -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
+ ++ "probably because too many return values."
+
+ let
+ -- The x86_64 ABI requires us to set %al to the number of SSE2
+ -- registers that contain arguments, if the called routine
+ -- is a varargs function. We don't know whether it's a
+ -- varargs function or not, so we have to assume it is.
+ --
+ -- It's not safe to omit this assignment, even if the number
+ -- of SSE2 regs in use is zero. If %al is larger than 8
+ -- on entry to a varargs function, seg faults ensue.
+ assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
+
+ let call = callinsns `appOL`
+ toOL (
+ -- Deallocate parameters after call for ccall;
+ -- 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)])
+ ++
+ [DELTA (delta + real_size)]
+ )
+ setDeltaNat (delta + real_size)
+
+ let
+ -- assign the results, if necessary
+ assign_code [] = nilOL
+ assign_code [dest] =
+ case typeWidth rep of
+ W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)
+ (OpReg xmm0)
+ (OpReg r_dest))
+ W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)
+ (OpReg xmm0)
+ (OpReg r_dest))
+ _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))
+ where
+ rep = localRegType dest
+ r_dest = getRegisterReg platform (CmmLocal dest)
+ assign_code _many = panic "genCCall.assign_code many"
+
+ return (adjust_rsp `appOL`
+ push_code `appOL`
+ load_args_code `appOL`
+ assign_args_code `appOL`
+ lss_code `appOL`
+ assign_eax sse_regs `appOL`
+ call `appOL`
+ assign_code dest_regs)
+
+
+maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr
+maybePromoteCArg platform wto arg
| wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]
| otherwise = arg
where
- wfrom = cmmExprWidth dflags arg
+ wfrom = cmmExprWidth platform arg
outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
-> NatM InstrBlock
@@ -3257,7 +3255,7 @@ genSwitch expr targets = do
let platform = ncgPlatform config
if ncgPIC config
then do
- (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)
+ (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset)
-- getNonClobberedReg because it needs to survive across t_code
lbl <- getNewLabelNat
let is32bit = target32Bit platform
@@ -3298,7 +3296,7 @@ genSwitch expr targets = do
JMP_TBL (OpReg tableReg) ids rosection lbl
]
else do
- (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+ (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
lbl <- getNewLabelNat
let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))
code = e_code `appOL` toOL [
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 5aa216f6ba..0dfd394d8e 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -507,11 +507,8 @@ pprAlignForSection platform seg =
_ -> int 8
pprDataItem :: NCGConfig -> CmmLit -> SDoc
-pprDataItem config lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags config lit
-
-pprDataItem' :: DynFlags -> NCGConfig -> CmmLit -> SDoc
-pprDataItem' dflags config lit
- = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+pprDataItem config lit
+ = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
platform = ncgPlatform config
imm = litToImm lit
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 7944f6a0fc..71b0793057 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}
+{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--
@@ -68,7 +69,7 @@ import Data.Array.ST
-- Top level
writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()
-writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)
+writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine)
-- --------------------------------------------------------------------------
-- Now do some real work
@@ -76,57 +77,59 @@ writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: RawCmmGroup -> SDoc
-pprC tops = vcat $ intersperse blankLine $ map pprTop tops
+pprC :: DynFlags -> RawCmmGroup -> SDoc
+pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops
--
-- top level procs
--
-pprTop :: RawCmmDecl -> SDoc
-pprTop (CmmProc infos clbl _in_live_regs graph) =
-
+pprTop :: DynFlags -> RawCmmDecl -> SDoc
+pprTop dflags = \case
+ (CmmProc infos clbl _in_live_regs graph) ->
(case mapLookup (g_entry graph) infos of
Nothing -> empty
Just (RawCmmStatics info_clbl info_dat) ->
- pprDataExterns info_dat $$
- pprWordArray info_is_in_rodata info_clbl info_dat) $$
+ pprDataExterns platform info_dat $$
+ pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$
(vcat [
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
nest 8 temp_decls,
- vcat (map pprBBlock blocks),
+ vcat (map (pprBBlock dflags) blocks),
rbrace ]
)
- where
+ where
-- info tables are always in .rodata
info_is_in_rodata = True
blocks = toBlockListEntryFirst graph
- (temp_decls, extern_decls) = pprTempAndExternDecls blocks
+ (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
--- Chunks of static data.
+ -- Chunks of static data.
--- We only handle (a) arrays of word-sized things and (b) strings.
+ -- We only handle (a) arrays of word-sized things and (b) strings.
-pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) =
- pprExternDecl lbl $$
- hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
- text "[] = ", pprStringInCStyle str, semi
- ]
+ (CmmData section (RawCmmStatics lbl [CmmString str])) ->
+ pprExternDecl platform lbl $$
+ hcat [
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+ text "[] = ", pprStringInCStyle str, semi
+ ]
-pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) =
- pprExternDecl lbl $$
- hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
- brackets (int size), semi
- ]
+ (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) ->
+ pprExternDecl platform lbl $$
+ hcat [
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+ brackets (int size), semi
+ ]
-pprTop (CmmData section (RawCmmStatics lbl lits)) =
- pprDataExterns lits $$
- pprWordArray (isSecConstant section) lbl lits
+ (CmmData section (RawCmmStatics lbl lits)) ->
+ pprDataExterns platform lits $$
+ pprWordArray dflags (isSecConstant section) lbl lits
+ where
+ platform = targetPlatform dflags
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
@@ -135,10 +138,10 @@ pprTop (CmmData section (RawCmmStatics lbl lits)) =
-- as many jumps as possible into fall throughs.
--
-pprBBlock :: CmmBlock -> SDoc
-pprBBlock block =
+pprBBlock :: DynFlags -> CmmBlock -> SDoc
+pprBBlock dflags block =
nest 4 (pprBlockId (entryLabel block) <> colon) $$
- nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
+ nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last)
where
(_, nodes, last) = blockSplit block
@@ -146,18 +149,19 @@ pprBBlock block =
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach
-pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
-pprWordArray is_ro lbl ds
- = sdocWithDynFlags $ \dflags ->
- -- TODO: align closures only
- pprExternDecl lbl $$
+pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc
+pprWordArray dflags is_ro lbl ds
+ = -- TODO: align closures only
+ pprExternDecl platform lbl $$
hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
, space, ppr lbl, text "[]"
-- See Note [StgWord alignment]
- , pprAlignment (wordWidth dflags)
+ , pprAlignment (wordWidth platform)
, text "= {" ]
$$ nest 8 (commafy (pprStatics dflags ds))
$$ text "};"
+ where
+ platform = targetPlatform dflags
pprAlignment :: Width -> SDoc
pprAlignment words =
@@ -195,10 +199,9 @@ pprConstness is_ro | is_ro = text "const "
-- Statements.
--
-pprStmt :: CmmNode e x -> SDoc
+pprStmt :: DynFlags -> CmmNode e x -> SDoc
-pprStmt stmt =
- sdocWithDynFlags $ \dflags ->
+pprStmt dflags stmt =
case stmt of
CmmEntry{} -> empty
CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
@@ -213,15 +216,16 @@ pprStmt stmt =
CmmAssign dest src -> pprAssign dflags dest src
CmmStore dest src
- | typeWidth rep == W64 && wordWidth dflags /= W64
+ | typeWidth rep == W64 && wordWidth platform /= W64
-> (if isFloatType rep then text "ASSIGN_DBL"
else ptext (sLit ("ASSIGN_Word64"))) <>
- parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+ parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi
| otherwise
- -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+ -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ]
where
- rep = cmmExprType dflags src
+ rep = cmmExprType platform src
+ platform = targetPlatform dflags
CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
fnCall
@@ -229,28 +233,29 @@ pprStmt stmt =
(res_hints, arg_hints) = foreignTargetHints target
hresults = zip results res_hints
hargs = zip args arg_hints
+ platform = targetPlatform dflags
ForeignConvention cconv _ _ ret = conv
- cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
+ cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn)
-- See wiki:commentary/compiler/backends/ppr-c#prototypes
fnCall =
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- pprCall (ppr lbl) cconv hresults hargs
+ pprCall dflags (ppr lbl) cconv hresults hargs
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
- pprCall cast_fn cconv hresults hargs <> semi
+ pprCall dflags cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
- pprForeignCall (ppr lbl) cconv hresults hargs
+ pprForeignCall dflags (ppr lbl) cconv hresults hargs
_ ->
- pprCall cast_fn cconv hresults hargs <> semi
+ pprCall dflags cast_fn cconv hresults hargs <> semi
-- for a dynamic call, no declaration is necessary.
CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
@@ -273,39 +278,38 @@ pprStmt stmt =
-- builtins (see bug #5967).
| Just _align <- machOpMemcpyishAlign op
= (text ";EFF_(" <> fn <> char ')' <> semi) $$
- pprForeignCall fn cconv hresults hargs
+ pprForeignCall dflags fn cconv hresults hargs
| otherwise
- = pprCall fn cconv hresults hargs
+ = pprCall dflags fn cconv hresults hargs
- CmmBranch ident -> pprBranch ident
- CmmCondBranch expr yes no _ -> pprCondBranch expr yes no
- CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
- CmmSwitch arg ids -> sdocWithDynFlags $ \dflags ->
- pprSwitch dflags arg ids
+ CmmBranch ident -> pprBranch ident
+ CmmCondBranch expr yes no _ -> pprCondBranch dflags expr yes no
+ CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi
+ CmmSwitch arg ids -> pprSwitch dflags arg ids
_other -> pprPanic "PprC.pprStmt" (ppr stmt)
type Hinted a = (a, ForeignHint)
-pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
+pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
-> SDoc
-pprForeignCall fn cconv results args = fn_call
+pprForeignCall dflags fn cconv results args = fn_call
where
+ platform = targetPlatform dflags
fn_call = braces (
- pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+ pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
- $$ pprCall (text "ghcFunPtr") cconv results args <> semi
+ $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi
)
- cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
+ cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn)
-pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
-pprCFunType ppr_fn cconv ress args
- = sdocWithDynFlags $ \dflags ->
- let res_type [] = text "void"
- res_type [(one, hint)] = machRepHintCType (localRegType one) hint
+pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCFunType platform ppr_fn cconv ress args
+ = let res_type [] = text "void"
+ res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint
res_type _ = panic "pprCFunType: only void or 1 return value supported"
- arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
+ arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint
in res_type ress <+>
parens (ccallConvAttribute cconv <> ppr_fn) <>
parens (commafy (map arg_type args))
@@ -318,9 +322,9 @@ pprBranch ident = text "goto" <+> pprBlockId ident <> semi
-- ---------------------------------------------------------------------
-- conditional branches to local labels
-pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
-pprCondBranch expr yes no
- = hsep [ text "if" , parens(pprExpr expr) ,
+pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc
+pprCondBranch dflags expr yes no
+ = hsep [ text "if" , parens(pprExpr dflags expr) ,
text "goto", pprBlockId yes <> semi,
text "else goto", pprBlockId no <> semi ]
@@ -331,20 +335,21 @@ pprCondBranch expr yes no
--
pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch dflags e ids
- = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)
+ = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace)
4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
where
(pairs, mbdef) = switchTargetsFallThrough ids
+ platform = targetPlatform dflags
-- fall through case
caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
where
do_fallthrough ix =
- hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+ hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,
text "/* fall through */" ]
final_branch ix =
- hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+ hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,
text "goto" , (pprBlockId ident) <> semi ]
caseify (_ , _ ) = panic "pprSwitch: switch with no cases!"
@@ -366,72 +371,73 @@ pprSwitch dflags e ids
--
-- (similar invariants apply to the rest of the pretty printer).
-pprExpr :: CmmExpr -> SDoc
-pprExpr e = case e of
- CmmLit lit -> pprLit lit
-
-
- CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
+pprExpr :: DynFlags -> CmmExpr -> SDoc
+pprExpr dflags e = case e of
+ CmmLit lit -> pprLit dflags lit
+ CmmLoad e ty -> pprLoad dflags e ty
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
-- CmmRegOff is an alias of MO_Add
- CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->
- pprCastReg reg <> char '+' <>
- pprHexVal (fromIntegral i) (wordWidth dflags)
+ CmmRegOff reg i -> pprCastReg reg <> char '+' <>
+ pprHexVal dflags (fromIntegral i) (wordWidth platform)
- CmmMachOp mop args -> pprMachOpApp mop args
+ CmmMachOp mop args -> pprMachOpApp dflags mop args
CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"
+ where
+ platform = targetPlatform dflags
pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad dflags e ty
- | width == W64, wordWidth dflags /= W64
+ | width == W64, wordWidth platform /= W64
= (if isFloatType ty then text "PK_DBL"
else text "PK_Word64")
- <> parens (mkP_ <> pprExpr1 e)
+ <> parens (mkP_ <> pprExpr1 dflags e)
| otherwise
= case e of
- CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+ CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty)
-> char '*' <> pprAsPtrReg r
- CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+ CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty)
-> char '*' <> pprAsPtrReg r
- CmmRegOff r off | isPtrReg r && width == wordWidth dflags
- , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)
+ CmmRegOff r off | isPtrReg r && width == wordWidth platform
+ , off `rem` platformWordSizeInBytes platform == 0 && not (isFloatType ty)
-- ToDo: check that the offset is a word multiple?
-- (For tagging to work, I had to avoid unaligned loads. --ARY)
- -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))
+ -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform))
- _other -> cLoad (targetPlatform dflags) e ty
+ _other -> cLoad dflags e ty
where
width = typeWidth ty
+ platform = targetPlatform dflags
-pprExpr1 :: CmmExpr -> SDoc
-pprExpr1 (CmmLit lit) = pprLit1 lit
-pprExpr1 e@(CmmReg _reg) = pprExpr e
-pprExpr1 other = parens (pprExpr other)
+pprExpr1 :: DynFlags -> CmmExpr -> SDoc
+pprExpr1 dflags e = case e of
+ CmmLit lit -> pprLit1 dflags lit
+ CmmReg _reg -> pprExpr dflags e
+ _ -> parens (pprExpr dflags e)
-- --------------------------------------------------------------------------
-- MachOp applications
-pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp op args
+pprMachOpApp dflags op args
| isMulMayOfloOp op
- = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))
+ = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args))
where isMulMayOfloOp (MO_U_MulMayOflo _) = True
isMulMayOfloOp (MO_S_MulMayOflo _) = True
isMulMayOfloOp _ = False
-pprMachOpApp mop args
+pprMachOpApp dflags mop args
| Just ty <- machOpNeedsCast mop
- = ty <> parens (pprMachOpApp' mop args)
+ = ty <> parens (pprMachOpApp' dflags mop args)
| otherwise
- = pprMachOpApp' mop args
+ = pprMachOpApp' dflags mop args
-- Comparisons in C have type 'int', but we want type W_ (this is what
-- resultRepOfMachOp says). The other C operations inherit their type
@@ -441,24 +447,23 @@ machOpNeedsCast mop
| isComparisonMachOp mop = Just mkW_
| otherwise = Nothing
-pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp' mop args
+pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp' dflags mop args
= case args of
-- dyadic
- [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
+ [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y
-- unary
- [x] -> pprMachOp_for_C mop <> parens (pprArg x)
+ [x] -> pprMachOp_for_C platform mop <> parens (pprArg x)
_ -> panic "PprC.pprMachOp : machop with wrong number of args"
where
+ platform = targetPlatform dflags
-- Cast needed for signed integer ops
- pprArg e | signedOp mop = sdocWithDynFlags $ \dflags ->
- cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
- | needsFCasts mop = sdocWithDynFlags $ \dflags ->
- cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
- | otherwise = pprExpr1 e
+ pprArg e | signedOp mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e
+ | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e
+ | otherwise = pprExpr1 dflags e
needsFCasts (MO_F_Eq _) = False
needsFCasts (MO_F_Ne _) = False
needsFCasts (MO_F_Neg _) = True
@@ -468,9 +473,9 @@ pprMachOpApp' mop args
-- --------------------------------------------------------------------------
-- Literals
-pprLit :: CmmLit -> SDoc
-pprLit lit = case lit of
- CmmInt i rep -> pprHexVal i rep
+pprLit :: DynFlags -> CmmLit -> SDoc
+pprLit dflags lit = case lit of
+ CmmInt i rep -> pprHexVal dflags i rep
CmmFloat f w -> parens (machRep_F_CType w) <> str
where d = fromRational f :: Double
@@ -496,71 +501,75 @@ pprLit lit = case lit of
where
pprCLabelAddr lbl = char '&' <> ppr lbl
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
-pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)
-pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
-pprLit1 other = pprLit other
+pprLit1 :: DynFlags -> CmmLit -> SDoc
+pprLit1 dflags lit = case lit of
+ (CmmLabelOff _ _) -> parens (pprLit dflags lit)
+ (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit)
+ (CmmFloat _ _) -> parens (pprLit dflags lit)
+ _ -> pprLit dflags lit
-- ---------------------------------------------------------------------------
-- Static data
pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
-pprStatics _ [] = []
-pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
- -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
- | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
- = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
- -- adjacent floats aren't padded but combined into a single word
- | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest
- = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'
- | wORD_SIZE dflags == 4
- = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
- | otherwise
- = pprPanic "pprStatics: float" (vcat (map ppr' rest))
- where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
- ppr (cmmLitType dflags l)
- ppr' _other = text "bad static!"
-pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
- = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
-
-pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
- | wordWidth dflags == W32
- = if wORDS_BIGENDIAN dflags
- then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
- CmmStaticLit (CmmInt r W32) : rest)
- else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
- CmmStaticLit (CmmInt q W32) : rest)
- where r = i .&. 0xffffffff
- q = i `shiftR` 32
-pprStatics dflags (CmmStaticLit (CmmInt a W32) :
- CmmStaticLit (CmmInt b W32) : rest)
- | wordWidth dflags == W64
- = if wORDS_BIGENDIAN dflags
- then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :
- rest)
- else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :
- rest)
-pprStatics dflags (CmmStaticLit (CmmInt a W16) :
- CmmStaticLit (CmmInt b W16) : rest)
- | wordWidth dflags == W32
- = if wORDS_BIGENDIAN dflags
- then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :
- rest)
- else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :
- rest)
-pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
- | w /= wordWidth dflags
- = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
-pprStatics dflags (CmmStaticLit lit : rest)
- = pprLit1 lit : pprStatics dflags rest
-pprStatics _ (other : _)
- = pprPanic "pprStatics: other" (pprStatic other)
-
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
-
- CmmStaticLit lit -> nest 4 (pprLit lit)
+pprStatics dflags = pprStatics'
+ where
+ platform = targetPlatform dflags
+ pprStatics' = \case
+ [] -> []
+ (CmmStaticLit (CmmFloat f W32) : rest)
+ -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
+ | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
+ -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest'
+ -- adjacent floats aren't padded but combined into a single word
+ | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest
+ -> pprLit1 dflags (floatPairToWord dflags f g) : pprStatics' rest'
+ | wordWidth platform == W32
+ -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest
+ | otherwise
+ -> pprPanic "pprStatics: float" (vcat (map ppr' rest))
+ where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)
+ ppr' _other = text "bad static!"
+
+ (CmmStaticLit (CmmFloat f W64) : rest)
+ -> map (pprLit1 dflags) (doubleToWords dflags f) ++ pprStatics' rest
+
+ (CmmStaticLit (CmmInt i W64) : rest)
+ | wordWidth platform == W32
+ -> if wORDS_BIGENDIAN dflags
+ then pprStatics' (CmmStaticLit (CmmInt q W32) :
+ CmmStaticLit (CmmInt r W32) : rest)
+ else pprStatics' (CmmStaticLit (CmmInt r W32) :
+ CmmStaticLit (CmmInt q W32) : rest)
+ where r = i .&. 0xffffffff
+ q = i `shiftR` 32
+
+ (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)
+ | wordWidth platform == W64
+ -> if wORDS_BIGENDIAN dflags
+ then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)
+ else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)
+
+ (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)
+ | wordWidth platform == W32
+ -> if wORDS_BIGENDIAN dflags
+ then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)
+ else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)
+
+ (CmmStaticLit (CmmInt _ w) : _)
+ | w /= wordWidth platform
+ -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
+
+ (CmmStaticLit lit : rest)
+ -> pprLit1 dflags lit : pprStatics' rest
+
+ (other : _)
+ -> pprPanic "pprStatics: other" (pprStatic dflags other)
+
+pprStatic :: DynFlags -> CmmStatic -> SDoc
+pprStatic dflags s = case s of
+
+ CmmStaticLit lit -> nest 4 (pprLit dflags lit)
CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-- these should be inlined, like the old .hc
@@ -577,9 +586,9 @@ pprBlockId b = char '_' <> ppr (getUnique b)
-- Print a MachOp in a way suitable for emitting via C.
--
-pprMachOp_for_C :: MachOp -> SDoc
+pprMachOp_for_C :: Platform -> MachOp -> SDoc
-pprMachOp_for_C mop = case mop of
+pprMachOp_for_C platform mop = case mop of
-- Integer operations
MO_Add _ -> char '+'
@@ -640,19 +649,19 @@ pprMachOp_for_C mop = case mop of
-- noop casts
MO_UU_Conv from to | from == to -> empty
- MO_UU_Conv _from to -> parens (machRep_U_CType to)
+ MO_UU_Conv _from to -> parens (machRep_U_CType platform to)
MO_SS_Conv from to | from == to -> empty
- MO_SS_Conv _from to -> parens (machRep_S_CType to)
+ MO_SS_Conv _from to -> parens (machRep_S_CType platform to)
MO_XX_Conv from to | from == to -> empty
- MO_XX_Conv _from to -> parens (machRep_U_CType to)
+ MO_XX_Conv _from to -> parens (machRep_U_CType platform to)
MO_FF_Conv from to | from == to -> empty
MO_FF_Conv _from to -> parens (machRep_F_CType to)
MO_SF_Conv _from to -> parens (machRep_F_CType to)
- MO_FS_Conv _from to -> parens (machRep_S_CType to)
+ MO_FS_Conv _from to -> parens (machRep_S_CType platform to)
MO_S_MulMayOflo _ -> pprTrace "offending mop:"
(text "MO_S_MulMayOflo")
@@ -875,10 +884,11 @@ pprAssign _ r1 (CmmReg r2)
-- dest is a reg, rhs is a CmmRegOff
pprAssign dflags r1 (CmmRegOff r2 off)
- | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
+ | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0)
= hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
where
- off1 = off `shiftR` wordShift dflags
+ platform = targetPlatform dflags
+ off1 = off `shiftR` wordShift platform
(op,off') | off >= 0 = (char '+', off1)
| otherwise = (char '-', -off1)
@@ -886,10 +896,10 @@ pprAssign dflags r1 (CmmRegOff r2 off)
-- dest is a reg, rhs is anything.
-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
-pprAssign _ r1 r2
- | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
- | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
- | otherwise = mkAssign (pprExpr r2)
+pprAssign dflags r1 r2
+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 dflags r2)
+ | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2)
+ | otherwise = mkAssign (pprExpr dflags r2)
where mkAssign x = if r1 == CmmGlobal BaseReg
then text "ASSIGN_BaseReg" <> parens x <> semi
else pprReg r1 <> text " = " <> x <> semi
@@ -988,8 +998,8 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
-pprCall ppr_fn cconv results args
+pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCall dflags ppr_fn cconv results args
| not (is_cishCC cconv)
= panic $ "pprCall: unknown calling convention"
@@ -997,6 +1007,8 @@ pprCall ppr_fn cconv results args
=
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
+ platform = targetPlatform dflags
+
ppr_assign [] rhs = rhs
ppr_assign [(one,hint)] rhs
= pprLocalReg one <> text " = "
@@ -1004,16 +1016,15 @@ pprCall ppr_fn cconv results args
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, AddrHint)
- = cCast (text "void *") expr
+ = cCast dflags (text "void *") expr
-- see comment by machRepHintCType below
pprArg (expr, SignedHint)
- = sdocWithDynFlags $ \dflags ->
- cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
+ = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr
pprArg (expr, _other)
- = pprExpr expr
+ = pprExpr dflags expr
- pprUnHint AddrHint rep = parens (machRepCType rep)
- pprUnHint SignedHint rep = parens (machRepCType rep)
+ pprUnHint AddrHint rep = parens (machRepCType platform rep)
+ pprUnHint SignedHint rep = parens (machRepCType platform rep)
pprUnHint _ _ = empty
-- Currently we only have these two calling conventions, but this might
@@ -1029,23 +1040,23 @@ is_cishCC JavaScriptCallConv = False
-- Find and print local and external declarations for a list of
-- Cmm statements.
--
-pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
-pprTempAndExternDecls stmts
- = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
- vcat (map pprExternDecl (Map.keys lbls)))
+pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls platform stmts
+ = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)),
+ vcat (map (pprExternDecl platform) (Map.keys lbls)))
where (temps, lbls) = runTE (mapM_ te_BB stmts)
-pprDataExterns :: [CmmStatic] -> SDoc
-pprDataExterns statics
- = vcat (map pprExternDecl (Map.keys lbls))
+pprDataExterns :: Platform -> [CmmStatic] -> SDoc
+pprDataExterns platform statics
+ = vcat (map (pprExternDecl platform) (Map.keys lbls))
where (_, lbls) = runTE (mapM_ te_Static statics)
-pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _ rep)
- = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+pprTempDecl :: Platform -> LocalReg -> SDoc
+pprTempDecl platform l@(LocalReg _ rep)
+ = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ]
-pprExternDecl :: CLabel -> SDoc
-pprExternDecl lbl
+pprExternDecl :: Platform -> CLabel -> SDoc
+pprExternDecl platform lbl
-- do not print anything for "known external" things
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
@@ -1072,9 +1083,9 @@ pprExternDecl lbl
-- If the label we want to refer to is a stdcall function (on Windows) then
-- we must generate an appropriate prototype for it, so that the C compiler will
-- add the @n suffix to the label (#2276)
- stdcall_decl sz = sdocWithDynFlags $ \dflags ->
+ stdcall_decl sz =
text "extern __attribute__((stdcall)) void " <> ppr lbl
- <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
+ <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
<> semi
type TEState = (UniqSet LocalReg, Map CLabel ())
@@ -1142,18 +1153,18 @@ te_Reg _ = return ()
-- ---------------------------------------------------------------------
-- C types for MachReps
-cCast :: SDoc -> CmmExpr -> SDoc
-cCast ty expr = parens ty <> pprExpr1 expr
+cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc
+cCast dflags ty expr = parens ty <> pprExpr1 dflags expr
-cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
-cLoad platform expr rep
+cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
+cLoad dflags expr rep
= if bewareLoadStoreAlignment (platformArch platform)
- then let decl = machRepCType rep <+> text "x" <> semi
+ then let decl = machRepCType platform rep <+> text "x" <> semi
struct = text "struct" <+> braces (decl)
packed_attr = text "__attribute__((packed))"
cast = parens (struct <+> packed_attr <> char '*')
- in parens (cast <+> pprExpr1 expr) <> text "->x"
- else char '*' <> parens (cCast (machRepPtrCType rep) expr)
+ in parens (cast <+> pprExpr1 dflags expr) <> text "->x"
+ else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr)
where -- On these platforms, unaligned loads are known to cause problems
bewareLoadStoreAlignment ArchAlpha = True
bewareLoadStoreAlignment ArchMipseb = True
@@ -1166,53 +1177,54 @@ cLoad platform expr rep
-- on unknown arches
bewareLoadStoreAlignment ArchUnknown = True
bewareLoadStoreAlignment _ = False
+ platform = targetPlatform dflags
-isCmmWordType :: DynFlags -> CmmType -> Bool
+isCmmWordType :: Platform -> CmmType -> Bool
-- True of GcPtrReg/NonGcReg of native word size
-isCmmWordType dflags ty = not (isFloatType ty)
- && typeWidth ty == wordWidth dflags
+isCmmWordType platform ty = not (isFloatType ty)
+ && typeWidth ty == wordWidth platform
-- This is for finding the types of foreign call arguments. For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
-machRepHintCType :: CmmType -> ForeignHint -> SDoc
-machRepHintCType _ AddrHint = text "void *"
-machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
-machRepHintCType rep _other = machRepCType rep
-
-machRepPtrCType :: CmmType -> SDoc
-machRepPtrCType r
- = sdocWithDynFlags $ \dflags ->
- if isCmmWordType dflags r then text "P_"
- else machRepCType r <> char '*'
-
-machRepCType :: CmmType -> SDoc
-machRepCType ty | isFloatType ty = machRep_F_CType w
- | otherwise = machRep_U_CType w
- where
- w = typeWidth ty
+machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc
+machRepHintCType platform rep = \case
+ AddrHint -> text "void *"
+ SignedHint -> machRep_S_CType platform (typeWidth rep)
+ _other -> machRepCType platform rep
+
+machRepPtrCType :: Platform -> CmmType -> SDoc
+machRepPtrCType platform r
+ = if isCmmWordType platform r
+ then text "P_"
+ else machRepCType platform r <> char '*'
+
+machRepCType :: Platform -> CmmType -> SDoc
+machRepCType platform ty
+ | isFloatType ty = machRep_F_CType w
+ | otherwise = machRep_U_CType platform w
+ where
+ w = typeWidth ty
machRep_F_CType :: Width -> SDoc
machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?
machRep_F_CType W64 = text "StgDouble"
machRep_F_CType _ = panic "machRep_F_CType"
-machRep_U_CType :: Width -> SDoc
-machRep_U_CType w
- = sdocWithDynFlags $ \dflags ->
- case w of
- _ | w == wordWidth dflags -> text "W_"
+machRep_U_CType :: Platform -> Width -> SDoc
+machRep_U_CType platform w
+ = case w of
+ _ | w == wordWidth platform -> text "W_"
W8 -> text "StgWord8"
W16 -> text "StgWord16"
W32 -> text "StgWord32"
W64 -> text "StgWord64"
_ -> panic "machRep_U_CType"
-machRep_S_CType :: Width -> SDoc
-machRep_S_CType w
- = sdocWithDynFlags $ \dflags ->
- case w of
- _ | w == wordWidth dflags -> text "I_"
+machRep_S_CType :: Platform -> Width -> SDoc
+machRep_S_CType platform w
+ = case w of
+ _ | w == wordWidth platform -> text "I_"
W8 -> text "StgInt8"
W16 -> text "StgInt16"
W32 -> text "StgInt32"
@@ -1266,11 +1278,12 @@ floatToWord dflags r
writeArray arr 0 (fromRational r)
arr' <- castFloatToWord32Array arr
w32 <- readArray arr' 0
- return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))
+ return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))
)
- where wo | wordWidth dflags == W64
+ where wo | wordWidth platform == W64
, wORDS_BIGENDIAN dflags = 32
| otherwise = 0
+ platform = targetPlatform dflags
floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
floatPairToWord dflags r1 r2
@@ -1300,7 +1313,8 @@ doubleToWords dflags r
w64 <- readArray arr' 0
return (pprWord64 w64)
)
- where targetWidth = wordWidth dflags
+ where targetWidth = wordWidth platform
+ platform = targetPlatform dflags
targetBE = wORDS_BIGENDIAN dflags
pprWord64 w64
| targetWidth == W64 =
@@ -1319,15 +1333,15 @@ doubleToWords dflags r
-- ---------------------------------------------------------------------------
-- Utils
-wordShift :: DynFlags -> Int
-wordShift dflags = widthInLog (wordWidth dflags)
+wordShift :: Platform -> Int
+wordShift platform = widthInLog (wordWidth platform)
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
-- Print in C hex format: 0x13fa
-pprHexVal :: Integer -> Width -> SDoc
-pprHexVal w rep
+pprHexVal :: DynFlags -> Integer -> Width -> SDoc
+pprHexVal dflags w rep
| w < 0 = parens (char '-' <>
text "0x" <> intToDoc (-w) <> repsuffix rep)
| otherwise = text "0x" <> intToDoc w <> repsuffix rep
@@ -1338,7 +1352,7 @@ pprHexVal w rep
-- times values are unsigned. This also helps eliminate occasional
-- warnings about integer overflow from gcc.
- repsuffix W64 = sdocWithDynFlags $ \dflags ->
+ repsuffix W64 =
if cINT_SIZE dflags == 8 then char 'U'
else if cLONG_SIZE dflags == 8 then text "UL"
else if cLONG_LONG_SIZE dflags == 8 then text "ULL"
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 9d97f3eb3c..b16e4cd00b 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -23,7 +23,7 @@ module GHC.CmmToLlvm.Base (
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
- ghcInternalFunctions,
+ ghcInternalFunctions, getPlatform,
getMetaUniqueId,
setUniqMeta, getUniqMeta,
@@ -134,17 +134,18 @@ llvmFunSig' live lbl link
= do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
dflags <- getDynFlags
+ platform <- getPlatform
return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
- (map (toParams . getVarType) (llvmFunArgs dflags live))
- (llvmFunAlign dflags)
+ (map (toParams . getVarType) (llvmFunArgs platform live))
+ (llvmFunAlign platform)
-- | Alignment to use for functions
-llvmFunAlign :: DynFlags -> LMAlign
-llvmFunAlign dflags = Just (wORD_SIZE dflags)
+llvmFunAlign :: Platform -> LMAlign
+llvmFunAlign platform = Just (platformWordSizeInBytes platform)
-- | Alignment to use for into tables
-llvmInfAlign :: DynFlags -> LMAlign
-llvmInfAlign dflags = Just (wORD_SIZE dflags)
+llvmInfAlign :: Platform -> LMAlign
+llvmInfAlign platform = Just (platformWordSizeInBytes platform)
-- | Section to use for a function
llvmFunSection :: DynFlags -> LMString -> LMSection
@@ -153,12 +154,11 @@ llvmFunSection dflags lbl
| otherwise = Nothing
-- | A Function's arguments
-llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
-llvmFunArgs dflags live =
- map (lmGlobalRegArg dflags) (filter isPassed allRegs)
- where platform = targetPlatform dflags
- allRegs = activeStgRegs platform
- paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live
+llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs platform live =
+ map (lmGlobalRegArg platform) (filter isPassed allRegs)
+ where allRegs = activeStgRegs platform
+ paddedLive = map (\(_,r) -> r) $ padLiveArgs platform live
isLive r = r `elem` alwaysLive || r `elem` paddedLive
isPassed r = not (isFPR r) || isLive r
@@ -217,14 +217,13 @@ fprRegNum _ = error "fprRegNum expected only FPR regs"
--
-- Also, the returned list is not sorted in any particular order.
--
-padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]
-padLiveArgs dflags live =
+padLiveArgs :: Platform -> LiveGlobalRegs -> [(Bool, GlobalReg)]
+padLiveArgs plat live =
if platformUnregisterised plat
then taggedLive -- not using GHC's register convention for platform.
else padding ++ taggedLive
where
taggedLive = map (\x -> (False, x)) live
- plat = targetPlatform dflags
fprLive = filter isFPR live
padding = concatMap calcPad $ groupBy sharesClass fprLive
@@ -232,7 +231,7 @@ padLiveArgs dflags live =
sharesClass :: GlobalReg -> GlobalReg -> Bool
sharesClass a b = sameFPRClass a b || overlappingClass
where
- overlappingClass = regsOverlap dflags (norm a) (norm b)
+ overlappingClass = regsOverlap plat (norm a) (norm b)
norm = CmmGlobal . normalizeFPRNum
calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]
@@ -269,8 +268,8 @@ tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams = map (\ty -> (ty, []))
-- | Pointer width
-llvmPtrBits :: DynFlags -> Int
-llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
+llvmPtrBits :: Platform -> Int
+llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform
-- ----------------------------------------------------------------------------
-- * Llvm Version
@@ -343,6 +342,9 @@ instance Monad LlvmM where
instance HasDynFlags LlvmM where
getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
+getPlatform :: LlvmM Platform
+getPlatform = targetPlatform <$> getDynFlags
+
instance MonadUnique LlvmM where
getUniqueSupplyM = do
mask <- getEnv envMask
@@ -484,11 +486,12 @@ getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
-- 'void *'). Fixes trac #5486.
ghcInternalFunctions :: LlvmM ()
ghcInternalFunctions = do
- dflags <- getDynFlags
- mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
- mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
- mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
- mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+ platform <- getPlatform
+ let w = llvmWord platform
+ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
+ mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
+ mk "memset" i8Ptr [i8Ptr, w, w]
+ mk "newSpark" w [i8Ptr, i8Ptr]
where
mk n ret args = do
let n' = llvmDefLabel $ fsLit n
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index e01c6fe886..a3f40ce306 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -292,12 +292,14 @@ genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall t@(PrimTarget op) [] args
- | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
- dflags <- getDynFlags
+ | Just align <- machOpMemcpyishAlign op
+ = do
+ platform <- getPlatform
+ runStmtsDecls $ do
let isVolTy = [i1]
isVolVal = [mkIntLit i1 0]
- argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
- | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
+ argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord platform, i32] ++ isVolTy
+ | otherwise = [i8Ptr, i8Ptr, llvmWord platform, i32] ++ isVolTy
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
@@ -396,13 +398,14 @@ genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-- Handle all other foreign calls and prim ops.
-genCall target res args = runStmtsDecls $ do
- dflags <- getDynFlags
+genCall target res args = do
+ platform <- getPlatform
+ runStmtsDecls $ do
-- parameter types
let arg_type (_, AddrHint) = i8Ptr
-- cast pointers to i8*. Llvm equivalent of void*
- arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
+ arg_type (expr, _) = cmmToLlvmType $ cmmExprType platform expr
-- ret type
let ret_type [] = LMVoid
@@ -451,7 +454,7 @@ genCall target res args = runStmtsDecls $ do
let retTy = ret_type ress_hints
let argTy = tysToParams $ map arg_type args_hints
let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
- lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
+ lmconv retTy FixedArgs argTy (llvmFunAlign platform)
argVars <- arg_varsW args_hints ([], nilOL, [])
@@ -716,11 +719,12 @@ castVar signage v t | getVarType v == t
| otherwise
= do dflags <- getDynFlags
+ platform <- getPlatform
let op = case (getVarType v, t) of
(LMInt n, LMInt m)
-> if n < m then extend else LM_Trunc
(vt, _) | isFloat vt && isFloat t
- -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
+ -> if llvmWidthInBits platform vt < llvmWidthInBits platform t
then LM_Fpext else LM_Fptrunc
(vt, _) | isInt vt && isFloat t -> LM_Sitofp
(vt, _) | isFloat vt && isInt t -> LM_Fptosi
@@ -748,8 +752,9 @@ cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions mop = do
dflags <- getDynFlags
- let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
- intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+ platform <- getPlatform
+ let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)
+ intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)
unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
++ " not supported here")
@@ -896,10 +901,10 @@ genAssign reg val = do
let stmts = stmts2
let ty = (pLower . getVarType) vreg
- dflags <- getDynFlags
+ platform <- getPlatform
case ty of
-- Some registers are pointer types, so need to cast value to pointer
- LMPointer _ | getVarType vval == llvmWord dflags -> do
+ LMPointer _ | getVarType vval == llvmWord platform -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
let s2 = Store v vreg
return (stmts `snocOL` s1 `snocOL` s2, top2)
@@ -949,10 +954,10 @@ genStore addr val
genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
-> LlvmM StmtData
genStore_fast addr r n val
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
(gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
meta <- getTBAARegMeta r
- let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
True -> do
(vval, stmts, top) <- exprToVar val
@@ -987,9 +992,10 @@ genStore_slow addr val meta = do
let stmts = stmts1 `appOL` stmts2
dflags <- getDynFlags
+ platform <- getPlatform
case getVarType vaddr of
-- sometimes we need to cast an int to a pointer before storing
- LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
+ LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
let s2 = MetaStmt meta $ Store v vaddr
return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
@@ -998,7 +1004,7 @@ genStore_slow addr val meta = do
let s1 = MetaStmt meta $ Store vval vaddr
return (stmts `snocOL` s1, top1 ++ top2)
- i@(LMInt _) | i == llvmWord dflags -> do
+ i@(LMInt _) | i == llvmWord platform -> do
let vty = pLift $ getVarType vval
(vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
let s2 = MetaStmt meta $ Store vval vptr
@@ -1006,9 +1012,9 @@ genStore_slow addr val meta = do
other ->
pprPanic "genStore: ptr not right type!"
- (PprCmm.pprExpr addr <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
- ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+ (PprCmm.pprExpr platform addr <+> text (
+ "Size of Ptr: " ++ show (llvmPtrBits platform) ++
+ ", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ showSDoc dflags (ppr vaddr)))
@@ -1170,8 +1176,8 @@ exprToVarOpt opt e = case e of
case isPointer ty of
True -> do
-- Cmm wants the value, so pointer types must be cast to ints
- dflags <- getDynFlags
- (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
+ platform <- getPlatform
+ (v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform)
return (v2, s1 `snocOL` s2, [])
False -> return (v1, s1, [])
@@ -1180,8 +1186,8 @@ exprToVarOpt opt e = case e of
-> genMachOp opt op exprs
CmmRegOff r i
- -> do dflags <- getDynFlags
- exprToVar $ expandCmmReg dflags (r, i)
+ -> do platform <- getPlatform
+ exprToVar $ expandCmmReg platform (r, i)
CmmStackSlot _ _
-> panic "exprToVar: CmmStackSlot not supported!"
@@ -1321,8 +1327,8 @@ genMachOp _ op [x] = case op of
let sameConv' op = do
(v1, s1) <- doExpr ty $ Cast op vx ty
return (v1, stmts `snocOL` s1, top)
- dflags <- getDynFlags
- let toWidth = llvmWidthInBits dflags ty
+ platform <- getPlatform
+ let toWidth = llvmWidthInBits platform ty
-- LLVM doesn't like trying to convert to same width, so
-- need to check for that as we do get Cmm code doing it.
case widthInBits from of
@@ -1351,12 +1357,12 @@ genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
-> LlvmM ExprData
genMachOp_fast opt op r n e
= do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
- dflags <- getDynFlags
- let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ platform <- getPlatform
+ let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
True -> do
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
- (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
+ (var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform)
return (var, s1 `snocOL` s2 `snocOL` s3, [])
False -> genMachOp_slow opt op e
@@ -1497,7 +1503,9 @@ genMachOp_slow opt op [x, y] = case op of
#endif
where
- binLlvmOp ty binOp = runExprData $ do
+ binLlvmOp ty binOp = do
+ platform <- getPlatform
+ runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
if getVarType vx == getVarType vy
@@ -1509,7 +1517,7 @@ genMachOp_slow opt op [x, y] = case op of
dflags <- getDynFlags
let style = mkCodeStyle CStyle
toString doc = renderWithStyle (initSDocContext dflags style) doc
- cmmToStr = (lines . toString . PprCmm.pprExpr)
+ cmmToStr = (lines . toString . PprCmm.pprExpr platform)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
doExprW (ty vx) $ binOp vx vy
@@ -1528,11 +1536,12 @@ genMachOp_slow opt op [x, y] = case op of
genBinComp opt cmp = do
ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
dflags <- getDynFlags
+ platform <- getPlatform
if getVarType v1 == i1
then case i1Expected opt of
True -> return ed
False -> do
- let w_ = llvmWord dflags
+ let w_ = llvmWord platform
(v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
return (v2, stmts `snocOL` s1, top)
else
@@ -1548,16 +1557,18 @@ genMachOp_slow opt op [x, y] = case op of
-- implementation. Its much longer due to type information/safety.
-- This should actually compile to only about 3 asm instructions.
isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
- isSMulOK _ x y = runExprData $ do
+ isSMulOK _ x y = do
+ platform <- getPlatform
+ dflags <- getDynFlags
+ runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
- dflags <- getDynFlags
let word = getVarType vx
- let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
- let shift = llvmWidthInBits dflags word
- let shift1 = toIWord dflags (shift - 1)
- let shift2 = toIWord dflags shift
+ let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx)
+ let shift = llvmWidthInBits platform word
+ let shift1 = toIWord platform (shift - 1)
+ let shift2 = toIWord platform shift
if isInt word
then do
@@ -1615,11 +1626,11 @@ genLoad atomic e ty
genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
-> LlvmM ExprData
genLoad_fast atomic e r n ty = do
- dflags <- getDynFlags
+ platform <- getPlatform
(gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
meta <- getTBAARegMeta r
let ty' = cmmToLlvmType ty
- (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
True -> do
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
@@ -1649,22 +1660,24 @@ genLoad_fast atomic e r n ty = do
-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
-genLoad_slow atomic e ty meta = runExprData $ do
+genLoad_slow atomic e ty meta = do
+ platform <- getPlatform
+ dflags <- getDynFlags
+ runExprData $ do
iptr <- exprToVarW e
- dflags <- getDynFlags
case getVarType iptr of
LMPointer _ -> do
doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
- i@(LMInt _) | i == llvmWord dflags -> do
+ i@(LMInt _) | i == llvmWord platform -> do
let pty = LMPointer $ cmmToLlvmType ty
ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
- (PprCmm.pprExpr e <+> text (
- "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
- ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+ (PprCmm.pprExpr platform e <+> text (
+ "Size of Ptr: " ++ show (llvmPtrBits platform) ++
+ ", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ showSDoc dflags (ppr iptr)))
where
loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
@@ -1688,8 +1701,9 @@ getCmmReg (CmmLocal (LocalReg un _))
getCmmReg (CmmGlobal g)
= do onStack <- checkStackReg g
dflags <- getDynFlags
+ platform <- getPlatform
if onStack
- then return (lmGlobalRegVar dflags g)
+ then return (lmGlobalRegVar platform g)
else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
-- | Return the value of a given register, as well as its type. Might
@@ -1699,9 +1713,9 @@ getCmmRegVal reg =
case reg of
CmmGlobal g -> do
onStack <- checkStackReg g
- dflags <- getDynFlags
+ platform <- getPlatform
if onStack then loadFromStack else do
- let r = lmGlobalRegArg dflags g
+ let r = lmGlobalRegArg platform g
return (r, getVarType r, nilOL)
_ -> loadFromStack
where loadFromStack = do
@@ -1751,33 +1765,33 @@ genLit opt (CmmVec ls)
genLit _ cmm@(CmmLabel l)
= do var <- getGlobalPtr =<< strCLabel_llvm l
- dflags <- getDynFlags
- let lmty = cmmToLlvmType $ cmmLitType dflags cmm
- (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+ platform <- getPlatform
+ let lmty = cmmToLlvmType $ cmmLitType platform cmm
+ (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform)
return (v1, unitOL s1, [])
genLit opt (CmmLabelOff label off) = do
- dflags <- getDynFlags
+ platform <- getPlatform
(vlbl, stmts, stat) <- genLit opt (CmmLabel label)
- let voff = toIWord dflags off
+ let voff = toIWord platform off
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
return (v1, stmts `snocOL` s1, stat)
genLit opt (CmmLabelDiffOff l1 l2 off w) = do
- dflags <- getDynFlags
+ platform <- getPlatform
(vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
(vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
- let voff = toIWord dflags off
+ let voff = toIWord platform off
let ty1 = getVarType vl1
let ty2 = getVarType vl2
if (isInt ty1) && (isInt ty2)
- && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
+ && (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2)
then do
(v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
(v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
let ty = widthToLlvmInt w
let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
- if w /= wordWidth dflags
+ if w /= wordWidth platform
then do
(v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
return (v3, stmts `snocOL` s3, stat1 ++ stat2)
@@ -1819,7 +1833,7 @@ funPrologue live cmmBlocks = do
assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
isLive r = r `elem` alwaysLive || r `elem` live
- dflags <- getDynFlags
+ platform <- getPlatform
stmtss <- flip mapM assignedRegs $ \reg ->
case reg of
CmmLocal (LocalReg un _) -> do
@@ -1827,8 +1841,8 @@ funPrologue live cmmBlocks = do
varInsert un (pLower $ getVarType newv)
return stmts
CmmGlobal r -> do
- let reg = lmGlobalRegVar dflags r
- arg = lmGlobalRegArg dflags r
+ let reg = lmGlobalRegVar platform r
+ arg = lmGlobalRegArg platform r
ty = (pLower . getVarType) reg
trash = LMLitVar $ LMUndefLit ty
rval = if isLive r then arg else trash
@@ -1845,11 +1859,11 @@ funPrologue live cmmBlocks = do
-- STG Liveness optimisation done here.
funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue live = do
- dflags <- getDynFlags
+ platform <- getPlatform
-- the bool indicates whether the register is padding.
let alwaysNeeded = map (\r -> (False, r)) alwaysLive
- livePadded = alwaysNeeded ++ padLiveArgs dflags live
+ livePadded = alwaysNeeded ++ padLiveArgs platform live
-- Set to value or "undef" depending on whether the register is
-- actually live
@@ -1857,7 +1871,7 @@ funEpilogue live = do
(v, _, s) <- getCmmRegVal (CmmGlobal r)
return (Just $ v, s)
loadUndef r = do
- let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+ let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
platform <- getDynFlag targetPlatform
let allRegs = activeStgRegs platform
@@ -1905,9 +1919,9 @@ doExpr ty expr = do
-- | Expand CmmRegOff
-expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
-expandCmmReg dflags (reg, off)
- = let width = typeWidth (cmmRegType dflags reg)
+expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr
+expandCmmReg platform (reg, off)
+ = let width = typeWidth (cmmRegType platform reg)
voff = CmmLit $ CmmInt (fromIntegral off) width
in CmmMachOp (MO_Add width) [CmmReg reg, voff]
@@ -1924,8 +1938,8 @@ mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
toI32 :: Integral a => a -> LlvmVar
toI32 = mkIntLit i32
-toIWord :: Integral a => DynFlags -> a -> LlvmVar
-toIWord dflags = mkIntLit (llvmWord dflags)
+toIWord :: Integral a => Platform -> a -> LlvmVar
+toIWord platform = mkIntLit (llvmWord platform)
-- | Error functions
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index 7a6320f947..deb1929968 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -169,23 +169,23 @@ genStaticLit (CmmVec ls)
-- Leave unresolved, will fix later
genStaticLit cmm@(CmmLabel l) = do
var <- getGlobalPtr =<< strCLabel_llvm l
- dflags <- getDynFlags
+ platform <- getPlatform
let ptr = LMStaticPointer var
- lmty = cmmToLlvmType $ cmmLitType dflags cmm
+ lmty = cmmToLlvmType $ cmmLitType platform cmm
return $ LMPtoI ptr lmty
genStaticLit (CmmLabelOff label off) = do
- dflags <- getDynFlags
+ platform <- getPlatform
var <- genStaticLit (CmmLabel label)
- let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+ let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform)
return $ LMAdd var offset
genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
- dflags <- getDynFlags
+ platform <- getPlatform
var1 <- genStaticLit (CmmLabel l1)
var2 <- genStaticLit (CmmLabel l2)
let var
- | w == wordWidth dflags = LMSub var1 var2
+ | w == wordWidth platform = LMSub var1 var2
| otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
return $ LMAdd var offset
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
index 45a8285ec6..f4540c212c 100644
--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -55,8 +55,9 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
funDec <- llvmFunSig live lbl link
dflags <- getDynFlags
+ platform <- getPlatform
let buildArg = fsLit . showSDoc dflags . ppPlainName
- funArgs = map buildArg (llvmFunArgs dflags live)
+ funArgs = map buildArg (llvmFunArgs platform live)
funSect = llvmFunSection dflags (decName funDec)
-- generate the info table
@@ -91,7 +92,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar)
i8Ptr)
- return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
+ return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])
-- | The section we are putting info tables and their entry code into, should
diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs
index af2a88c4c9..82a4ae18e2 100644
--- a/compiler/GHC/CmmToLlvm/Regs.hs
+++ b/compiler/GHC/CmmToLlvm/Regs.hs
@@ -16,25 +16,25 @@ import GhcPrelude
import GHC.Llvm
import GHC.Cmm.Expr
-import GHC.Driver.Session
+import GHC.Platform
import FastString
import Outputable ( panic )
import Unique
-- | Get the LlvmVar function variable storing the real register
-lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
-lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"
+lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar
+lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"
-- | Get the LlvmVar function argument storing the real register
-lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar
-lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"
+lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar
+lmGlobalRegArg platform = lmGlobalReg platform "_Arg"
{- Need to make sure the names here can't conflict with the unique generated
names. Uniques generated names containing only base62 chars. So using say
the '_' char guarantees this.
-}
-lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar
-lmGlobalReg dflags suf reg
+lmGlobalReg :: Platform -> String -> GlobalReg -> LlvmVar
+lmGlobalReg platform suf reg
= case reg of
BaseReg -> ptrGlobal $ "Base" ++ suf
Sp -> ptrGlobal $ "Sp" ++ suf
@@ -84,8 +84,8 @@ lmGlobalReg dflags suf reg
-- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
-- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
where
- wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags)
- ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)
+ wordGlobal name = LMNLocalVar (fsLit name) (llvmWord platform)
+ ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr platform)
floatGlobal name = LMNLocalVar (fsLit name) LMFloat
doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index 99a90c92e9..1cac00320f 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -204,19 +204,19 @@ newtype ByteOff = ByteOff Int
newtype WordOff = WordOff Int
deriving (Enum, Eq, Integral, Num, Ord, Real)
-wordsToBytes :: DynFlags -> WordOff -> ByteOff
-wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
+wordsToBytes :: Platform -> WordOff -> ByteOff
+wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral
-- Used when we know we have a whole number of words
-bytesToWords :: DynFlags -> ByteOff -> WordOff
-bytesToWords dflags (ByteOff bytes) =
- let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
+bytesToWords :: Platform -> ByteOff -> WordOff
+bytesToWords platform (ByteOff bytes) =
+ let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
in if r == 0
then fromIntegral q
else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes
-wordSize :: DynFlags -> ByteOff
-wordSize dflags = ByteOff (wORD_SIZE dflags)
+wordSize :: Platform -> ByteOff
+wordSize platform = ByteOff (platformWordSizeInBytes platform)
type Sequel = ByteOff -- back off to this depth before ENTER
@@ -381,6 +381,7 @@ schemeR_wrk fvs nm original_body (args, body)
= do
dflags <- getDynFlags
let
+ platform = targetPlatform dflags
all_args = reverse args ++ fvs
arity = length all_args
-- all_args are the args in reverse order. We're compiling a function
@@ -389,14 +390,14 @@ 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 dflags . idSizeW dflags) all_args
+ szsb_args = map (wordsToBytes platform . idSizeW dflags) 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))
bitmap_size = genericLength bits
- bitmap = mkBitmap dflags bits
+ bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
emitBc (mkProtoBCO dflags nm body_code (Right original_body)
@@ -410,7 +411,8 @@ schemeER_wrk d p rhs
cc_arr <- getCCArray
this_mod <- moduleName <$> getCurrentModule
dflags <- getDynFlags
- let idOffSets = getVarOffSets dflags d p fvs
+ let platform = targetPlatform dflags
+ let idOffSets = getVarOffSets platform d p fvs
let breakInfo = CgBreakInfo
{ cgb_vars = idOffSets
, cgb_resty = exprType (deAnnotate' newRhs)
@@ -425,8 +427,8 @@ schemeER_wrk d p rhs
return $ breakInstr `consOL` code
| otherwise = schemeE d 0 p rhs
-getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
-getVarOffSets dflags depth env = map getOffSet
+getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
+getVarOffSets platform depth env = map getOffSet
where
getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
@@ -439,7 +441,7 @@ getVarOffSets dflags depth env = map getOffSet
-- BRK_FUN in Interpreter.c In any case, this is used only when
-- we trigger a breakpoint.
let !var_depth_ws =
- trunc16W $ bytesToWords dflags (depth - offset) + 2
+ trunc16W $ bytesToWords platform (depth - offset) + 2
in Just (id, var_depth_ws)
truncIntegral16 :: Integral a => a -> Word16
@@ -482,10 +484,11 @@ returnUnboxedAtom
-- Heave it on the stack, SLIDE, and RETURN.
returnUnboxedAtom d s p e e_rep = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
(push, szb) <- pushAtom d p e
- return (push -- value onto stack
- `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
- `snocOL` RETURN_UBX e_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSlideB platform szb (d - s) -- clear to sequel
+ `snocOL` RETURN_UBX e_rep) -- go
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
@@ -516,7 +519,8 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
dflags <- getDynFlags
- let !d2 = d + wordSize dflags
+ let platform = targetPlatform dflags
+ let !d2 = d + wordSize platform
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
@@ -526,6 +530,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
dflags <- 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
@@ -544,9 +549,9 @@ schemeE d s p (AnnLet binds (_,body)) = do
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
- offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
+ offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))
p' = Map.insertList (zipE xs' offsets) p
- d' = d + wordsToBytes dflags n_binds
+ d' = d + wordsToBytes platform n_binds
zipE = zipEqual "schemeE"
-- ToDo: don't build thunks for things with no free variables
@@ -831,8 +836,9 @@ schemeT d s p app
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
dflags <- getDynFlags
+ let platform = targetPlatform dflags
return (alloc_con `appOL`
- mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
+ mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
ENTER)
-- Case 4: Tail call of function
@@ -875,6 +881,7 @@ mkConAppCode orig_d _ p con args_r_to_l =
where
app_code = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
-- The args are initially in reverse order, but mkVirtHeapOffsets
-- expects them to be left-to-right.
@@ -894,7 +901,7 @@ mkConAppCode orig_d _ p con args_r_to_l =
more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code)
do_pushery !d [] = do
- let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)
+ let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)
return (unitOL (PACK con n_arg_words))
-- Push on the stack in the reverse order.
@@ -928,15 +935,17 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
dflags <- getDynFlags
- ASSERT( sz == wordSize dflags ) return ()
- let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
+ let platform = targetPlatform dflags
+ ASSERT( sz == wordSize platform ) return ()
+ let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
return (push_fn `appOL` (slide `appOL` unitOL ENTER))
do_pushes !d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
(these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
dflags <- getDynFlags
- instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
+ let platform = targetPlatform dflags
+ instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
-- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
@@ -995,6 +1004,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
dflags <- getDynFlags
hsc_env <- getHscEnv
let
+ platform = targetPlatform dflags
profiling
| Just interp <- hsc_interp hsc_env
= interpreterProfiled interp
@@ -1005,21 +1015,21 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl.
ret_frame_size_b :: StackDepth
- ret_frame_size_b = 2 * wordSize dflags
+ ret_frame_size_b = 2 * wordSize platform
-- The extra frame we push to save/restore the CCCS when profiling
- save_ccs_size_b | profiling = 2 * wordSize dflags
+ save_ccs_size_b | profiling = 2 * wordSize platform
| otherwise = 0
-- An unlifted value gets an extra info table pushed on top
-- when it is returned.
unlifted_itbl_size_b :: StackDepth
unlifted_itbl_size_b | isAlgCase = 0
- | otherwise = wordSize dflags
+ | otherwise = wordSize platform
-- depth of stack after the return value has been pushed
d_bndr =
- d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
+ d + ret_frame_size_b + wordsToBytes platform (idSizeW dflags 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
@@ -1061,7 +1071,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
]
size = WordOff tot_wds
- stack_bot = d_alts + wordsToBytes dflags size
+ stack_bot = d_alts + wordsToBytes platform size
-- convert offsets from Sp into offsets into the virtual stack
p' = Map.insertList
@@ -1111,10 +1121,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- really want a bitmap up to depth (d-s). This affects compilation of
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
- bitmap_size = trunc16W $ bytesToWords dflags (d - s)
+ bitmap_size = trunc16W $ bytesToWords platform (d - s)
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
+ bitmap = intsToReverseBitmap platform bitmap_size'{-size-}
(sort (filter (< bitmap_size') rel_slots))
where
binds = Map.toList p
@@ -1123,7 +1133,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
rel_slots = nub $ map fromIntegral $ concatMap spread binds
spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
| otherwise = []
- where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
+ where rel_offset = trunc16W $ bytesToWords platform (d - offset)
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
@@ -1167,9 +1177,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
dflags <- getDynFlags
let
+ platform = targetPlatform dflags
-- useful constants
addr_size_b :: ByteOff
- addr_size_b = wordSize dflags
+ addr_size_b = wordSize platform
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
@@ -1228,7 +1239,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg
- !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
+ !d_after_args = d0 + wordsToBytes platform a_reps_sizeW
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))
= panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?"
@@ -1290,9 +1301,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
Just (LitLabel target mb_size IsFunction)
where
mb_size
- | OSMinGW32 <- platformOS (targetPlatform dflags)
+ | OSMinGW32 <- platformOS platform
, StdCallConv <- cconv
- = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
+ = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)
| otherwise
= Nothing
@@ -1316,7 +1327,7 @@ 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
- d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
+ d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
push_r =
if returns_void
then nilOL
@@ -1328,7 +1339,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- instruction needs to describe the chunk of stack containing
-- the ccall args to the GC, so it needs to know how large it
-- is. See comment in Interpreter.c with the CCALL instruction.
- stk_offset = trunc16W $ bytesToWords dflags (d_after_r - s)
+ stk_offset = trunc16W $ bytesToWords platform (d_after_r - s)
conv = case cconv of
CCallConv -> FFICCall
@@ -1340,8 +1351,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- address of this to the CCALL instruction.
- let ffires = primRepToFFIType dflags r_rep
- ffiargs = map (primRepToFFIType dflags) a_reps
+ let ffires = primRepToFFIType platform r_rep
+ ffiargs = map (primRepToFFIType platform) a_reps
hsc_env <- getHscEnv
token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
recordFFIBc token
@@ -1355,7 +1366,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
PlayRisky -> 0x2
-- slide and return
- d_after_r_min_s = bytesToWords dflags (d_after_r - s)
+ d_after_r_min_s = bytesToWords platform (d_after_r - s)
wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
`snocOL` RETURN_UBX (toArgRep r_rep)
--trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
@@ -1364,8 +1375,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
-primRepToFFIType :: DynFlags -> PrimRep -> FFIType
-primRepToFFIType dflags r
+primRepToFFIType :: Platform -> PrimRep -> FFIType
+primRepToFFIType platform r
= case r of
VoidRep -> FFIVoid
IntRep -> signed_word
@@ -1377,10 +1388,9 @@ primRepToFFIType dflags r
DoubleRep -> FFIDouble
_ -> panic "primRepToFFIType"
where
- (signed_word, unsigned_word)
- | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32)
- | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64)
- | otherwise = panic "primTyDescChar"
+ (signed_word, unsigned_word) = case platformWordSize platform of
+ PW4 -> (FFISInt32, FFIUInt32)
+ PW8 -> (FFISInt64, FFIUInt64)
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
@@ -1506,8 +1516,9 @@ implement_tagToId d s p arg names
dflags <- getDynFlags
let infos = zip4 labels (tail labels ++ [label_fail])
[0 ..] names
+ platform = targetPlatform dflags
steps = map (mkStep label_exit) infos
- slide_ws = bytesToWords dflags (d - s + arg_bytes)
+ slide_ws = bytesToWords platform (d - s + arg_bytes)
return (push_arg
`appOL` unitOL (PUSH_UBX LitNullAddr 1)
@@ -1564,24 +1575,26 @@ pushAtom d p (AnnVar var)
| Just primop <- isPrimOpId_maybe var
= do
- dflags <-getDynFlags
- return (unitOL (PUSH_PRIMOP primop), wordSize dflags)
+ dflags <- getDynFlags
+ let platform = targetPlatform dflags
+ 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
let !szb = idSizeCon dflags var
with_instr instr = do
let !off_b = trunc16B $ d - d_v
- return (unitOL (instr off_b), wordSize dflags)
+ return (unitOL (instr off_b), wordSize platform)
case szb of
1 -> with_instr PUSH8_W
2 -> with_instr PUSH16_W
4 -> with_instr PUSH32_W
_ -> do
- let !szw = bytesToWords dflags szb
- !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
+ let !szw = bytesToWords platform szb
+ !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1
return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
-- d - d_v offset from TOS to the first slot of the object
--
@@ -1598,16 +1611,18 @@ pushAtom d p (AnnVar var)
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
let sz = idSizeCon dflags var
- MASSERT( sz == wordSize dflags )
+ let platform = targetPlatform dflags
+ MASSERT( sz == wordSize platform )
return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
let code rep
= let size_words = WordOff (argRepSizeW dflags rep)
in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
- wordsToBytes dflags size_words)
+ wordsToBytes platform size_words)
case lit of
LitLabel _ _ _ -> code N
@@ -1858,11 +1873,11 @@ unsupportedCConvException = throwGhcException (ProgramError
("Error: bytecode compiler can't handle some foreign calling conventions\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
-mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
-mkSlideB dflags !nb !db = mkSlideW n d
+mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
+mkSlideB platform !nb !db = mkSlideW n d
where
- !n = trunc16W $ bytesToWords dflags nb
- !d = bytesToWords dflags db
+ !n = trunc16W $ bytesToWords platform nb
+ !d = bytesToWords platform db
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW !n !ws
diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs
index 985e74deb9..55700ddf9a 100644
--- a/compiler/GHC/Data/Bitmap.hs
+++ b/compiler/GHC/Data/Bitmap.hs
@@ -18,7 +18,6 @@ import GhcPrelude
import GHC.Platform
import GHC.Runtime.Heap.Layout
-import GHC.Driver.Session
import Data.Bits
@@ -30,32 +29,32 @@ generated code which need to be emitted as sequences of StgWords.
type Bitmap = [StgWord]
-- | Make a bitmap from a sequence of bits
-mkBitmap :: DynFlags -> [Bool] -> Bitmap
+mkBitmap :: Platform -> [Bool] -> Bitmap
mkBitmap _ [] = []
-mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest
- where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
+mkBitmap platform stuff = chunkToBitmap platform chunk : mkBitmap platform rest
+ where (chunk, rest) = splitAt (platformWordSizeInBits platform) stuff
-chunkToBitmap :: DynFlags -> [Bool] -> StgWord
-chunkToBitmap dflags chunk =
- foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]
+chunkToBitmap :: Platform -> [Bool] -> StgWord
+chunkToBitmap platform chunk =
+ foldl' (.|.) (toStgWord platform 0) [ oneAt n | (True,n) <- zip chunk [0..] ]
where
oneAt :: Int -> StgWord
- oneAt i = toStgWord dflags 1 `shiftL` i
+ oneAt i = toStgWord platform 1 `shiftL` i
-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0x4@ (we leave any bits outside the size as zero,
-- just to make the bitmap easier to read).
--
-- The list of @Int@s /must/ be already sorted and duplicate-free.
-intsToReverseBitmap :: DynFlags
+intsToReverseBitmap :: Platform
-> Int -- ^ size in bits
-> [Int] -- ^ sorted indices of zeros free of duplicates
-> Bitmap
-intsToReverseBitmap dflags size = go 0
+intsToReverseBitmap platform size = go 0
where
- word_sz = wORD_SIZE_IN_BITS dflags
+ word_sz = platformWordSizeInBits platform
oneAt :: Int -> StgWord
- oneAt i = toStgWord dflags 1 `shiftL` i
+ oneAt i = toStgWord platform 1 `shiftL` i
-- It is important that we maintain strictness here.
-- See Note [Strictness when building Bitmaps].
@@ -63,7 +62,7 @@ intsToReverseBitmap dflags size = go 0
go !pos slots
| size <= pos = []
| otherwise =
- (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :
+ (foldl' xor (toStgWord platform init) (map (\i->oneAt (i - pos)) these)) :
go (pos + word_sz) rest
where
(these,rest) = span (< (pos + word_sz)) slots
@@ -98,8 +97,8 @@ possible, or fall back to an external pointer when the bitmap is too
large. This value represents the largest size of bitmap that can be
packed into a single word.
-}
-mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int
-mAX_SMALL_BITMAP_SIZE dflags =
- case platformWordSize (targetPlatform dflags) of
+mAX_SMALL_BITMAP_SIZE :: Platform -> Int
+mAX_SMALL_BITMAP_SIZE platform =
+ case platformWordSize platform of
PW4 -> 27 -- On 32-bit: 5 bits for size, 27 bits for bitmap
PW8 -> 58 -- On 64-bit: 6 bits for size, 58 bits for bitmap
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 5b56e381ed..bdb8daebce 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -200,7 +200,6 @@ module GHC.Driver.Session (
#include "GHCConstantsHaskellExports.hs"
bLOCK_SIZE_W,
- wORD_SIZE_IN_BITS,
wordAlignment,
tAG_MASK,
mAX_PTR_TAG,
@@ -4920,9 +4919,6 @@ compilerInfo dflags
bLOCK_SIZE_W :: DynFlags -> Int
bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags
-wORD_SIZE_IN_BITS :: DynFlags -> Int
-wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8
-
wordAlignment :: DynFlags -> Alignment
wordAlignment dflags = alignmentOf (wORD_SIZE dflags)
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index e7f49191cf..0e19c375c6 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -158,6 +158,7 @@ dsCImport :: Id
dsCImport id co (CLabel cid) cconv _ _ = do
dflags <- getDynFlags
let ty = coercionLKind co
+ platform = targetPlatform dflags
fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
@@ -168,7 +169,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do
let
rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
rhs' = Cast rhs co
- stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
+ stdcall_info = fun_type_arg_stdcall_info platform cconv ty
in
return ([(id, rhs')], empty, empty)
@@ -182,14 +183,14 @@ dsCImport id co CWrapper cconv _ _
-- For stdcall labels, if the type was a FunPtr or newtype thereof,
-- then we need to calculate the size of the arguments in order to add
-- the @n suffix to the label.
-fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info dflags StdCallConv ty
+fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info platform StdCallConv ty
| Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
tyConUnique tc == funPtrTyConKey
= let
(bndrs, _) = tcSplitPiTys arg_ty
fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
+ in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
fun_type_arg_stdcall_info _ _other_conv _
= Nothing
@@ -524,6 +525,8 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
-- use that instead. I hope the two coincide --SDM
)
where
+ platform = targetPlatform dflags
+
-- list the arguments to the C function
arg_info :: [(SDoc, -- arg name
SDoc, -- C type
@@ -533,7 +536,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
(arg_cname n stg_type,
stg_type,
ty,
- typeCmmType dflags (getPrimTyOf ty))
+ typeCmmType platform (getPrimTyOf ty))
| (ty,n) <- zip arg_htys [1::Int ..] ]
arg_cname n stg_ty
@@ -555,12 +558,12 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
-- add some auxiliary args; the stable ptr in the wrapper case, and
-- a slot for the dummy return address in the wrapper + ccall case
aug_arg_info
- | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
+ | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
| otherwise = arg_info
stable_ptr_arg =
(text "the_stableptr", text "StgStablePtr", undefined,
- typeCmmType dflags (mkStablePtrPrimTy alphaTy))
+ typeCmmType platform (mkStablePtrPrimTy alphaTy))
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
@@ -741,10 +744,10 @@ typeTyCon ty
| otherwise
= pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
-insertRetAddr :: DynFlags -> CCallConv
+insertRetAddr :: Platform -> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
-insertRetAddr dflags CCallConv args
+insertRetAddr platform CCallConv args
= case platformArch platform of
ArchX86_64
| platformOS platform == OSMinGW32 ->
@@ -754,7 +757,7 @@ insertRetAddr dflags CCallConv args
-- (See rts/Adjustor.c for details).
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
- go 4 args = ret_addr_arg dflags : args
+ go 4 args = ret_addr_arg platform : args
go n (arg:args) = arg : go (n+1) args
go _ [] = []
in go 0 args
@@ -765,20 +768,19 @@ insertRetAddr dflags CCallConv args
-- (See rts/Adjustor.c for details).
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
- go 6 args = ret_addr_arg dflags : args
+ go 6 args = ret_addr_arg platform : args
go n (arg@(_,_,_,rep):args)
| cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
| otherwise = arg : go n args
go _ [] = []
in go 0 args
_ ->
- ret_addr_arg dflags : args
- where platform = targetPlatform dflags
+ ret_addr_arg platform : args
insertRetAddr _ _ args = args
-ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
-ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
- typeCmmType dflags addrPrimTy)
+ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
+ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
+ typeCmmType platform addrPrimTy)
-- This function returns the primitive type associated with the boxed
-- type argument to a foreign export (eg. Int ==> Int#).
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index 092dec39fb..b7c3564240 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -30,6 +30,7 @@ import GhcPrelude
import GHC.Llvm.Syntax
import GHC.Llvm.MetaData
import GHC.Llvm.Types
+import GHC.Platform
import Data.List ( intersperse )
import Outputable
@@ -41,14 +42,14 @@ import FastString ( sLit )
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmModule -> SDoc
-ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
+ppLlvmModule :: Platform -> LlvmModule -> SDoc
+ppLlvmModule platform (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
$+$ ppLlvmMetas meta $+$ newLine
$+$ ppLlvmGlobals globals $+$ newLine
$+$ ppLlvmFunctionDecls decls $+$ newLine
- $+$ ppLlvmFunctions funcs
+ $+$ ppLlvmFunctions platform funcs
-- | Print out a multi-line comment, can be inside a function or on its own
ppLlvmComments :: [LMString] -> SDoc
@@ -117,12 +118,12 @@ ppLlvmMeta (MetaNamed n m)
-- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmFunctions -> SDoc
-ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
+ppLlvmFunctions :: Platform -> LlvmFunctions -> SDoc
+ppLlvmFunctions platform funcs = vcat $ map (ppLlvmFunction platform) funcs
-- | Print out a function definition.
-ppLlvmFunction :: LlvmFunction -> SDoc
-ppLlvmFunction fun =
+ppLlvmFunction :: Platform -> LlvmFunction -> SDoc
+ppLlvmFunction platform fun =
let attrDoc = ppSpaceJoin (funcAttrs fun)
secDoc = case funcSect fun of
Just s' -> text "section" <+> (doubleQuotes $ ftext s')
@@ -133,7 +134,7 @@ ppLlvmFunction fun =
in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
<+> attrDoc <+> secDoc <+> prefixDoc
$+$ lbrace
- $+$ ppLlvmBlocks (funcBody fun)
+ $+$ ppLlvmBlocks platform (funcBody fun)
$+$ rbrace
$+$ newLine
$+$ newLine
@@ -177,21 +178,21 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
-- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmBlocks -> SDoc
-ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
+ppLlvmBlocks :: Platform -> LlvmBlocks -> SDoc
+ppLlvmBlocks platform blocks = vcat $ map (ppLlvmBlock platform) blocks
-- | Print out an LLVM block.
-- It must be part of a function definition.
-ppLlvmBlock :: LlvmBlock -> SDoc
-ppLlvmBlock (LlvmBlock blockId stmts) =
+ppLlvmBlock :: Platform -> LlvmBlock -> SDoc
+ppLlvmBlock platform (LlvmBlock blockId stmts) =
let isLabel (MkLabel _) = True
isLabel _ = False
(block, rest) = break isLabel stmts
ppRest = case rest of
- MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
+ MkLabel id:xs -> ppLlvmBlock platform (LlvmBlock id xs)
_ -> empty
in ppLlvmBlockLabel blockId
- $+$ (vcat $ map ppLlvmStatement block)
+ $+$ (vcat $ map (ppLlvmStatement platform) block)
$+$ newLine
$+$ ppRest
@@ -201,11 +202,11 @@ ppLlvmBlockLabel id = pprUniqueAlways id <> colon
-- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmStatement -> SDoc
-ppLlvmStatement stmt =
+ppLlvmStatement :: Platform -> LlvmStatement -> SDoc
+ppLlvmStatement platform stmt =
let ind = (text " " <>)
in case stmt of
- Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr)
+ Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression platform expr)
Fence st ord -> ind $ ppFence st ord
Branch target -> ind $ ppBranch target
BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
@@ -214,15 +215,15 @@ ppLlvmStatement stmt =
Store value ptr -> ind $ ppStore value ptr
Switch scrut def tgs -> ind $ ppSwitch scrut def tgs
Return result -> ind $ ppReturn result
- Expr expr -> ind $ ppLlvmExpression expr
+ Expr expr -> ind $ ppLlvmExpression platform expr
Unreachable -> ind $ text "unreachable"
Nop -> empty
- MetaStmt meta s -> ppMetaStatement meta s
+ MetaStmt meta s -> ppMetaStatement platform meta s
-- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmExpression -> SDoc
-ppLlvmExpression expr
+ppLlvmExpression :: Platform -> LlvmExpression -> SDoc
+ppLlvmExpression platform expr
= case expr of
Alloca tp amount -> ppAlloca tp amount
LlvmOp op left right -> ppMachOp op left right
@@ -235,13 +236,13 @@ ppLlvmExpression expr
Insert vec elt idx -> ppInsert vec elt idx
GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes
Load ptr -> ppLoad ptr
- ALoad ord st ptr -> ppALoad ord st ptr
+ ALoad ord st ptr -> ppALoad platform ord st ptr
Malloc tp amount -> ppMalloc tp amount
AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
Phi tp predecessors -> ppPhi tp predecessors
Asm asm c ty v se sk -> ppAsm asm c ty v se sk
- MExpr meta expr -> ppMetaExpr meta expr
+ MExpr meta expr -> ppMetaExpr platform meta expr
--------------------------------------------------------------------------------
@@ -360,9 +361,9 @@ ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
align | isVector . pLower . getVarType $ var = text ", align 1"
| otherwise = empty
-ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
-ppALoad ord st var = sdocWithDynFlags $ \dflags ->
- let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8
+ppALoad :: Platform -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad platform ord st var =
+ let alignment = (llvmWidthInBits platform $ getVarType var) `quot` 8
align = text ", align" <+> ppr alignment
sThreaded | st = text " singlethread"
| otherwise = empty
@@ -468,11 +469,13 @@ ppInsert vec elt idx =
<+> ppr idx
-ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
-ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
+ppMetaStatement :: Platform -> [MetaAnnot] -> LlvmStatement -> SDoc
+ppMetaStatement platform meta stmt =
+ ppLlvmStatement platform stmt <> ppMetaAnnots meta
-ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
-ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
+ppMetaExpr :: Platform -> [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaExpr platform meta expr =
+ ppLlvmExpression platform expr <> ppMetaAnnots meta
ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots meta = hcat $ map ppMeta meta
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index 3e320634d0..e8b4bc283a 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- | The LLVM Type System.
@@ -14,6 +15,7 @@ import Data.Char
import Data.Int
import Numeric
+import GHC.Platform
import GHC.Driver.Session
import FastString
import Outputable
@@ -351,23 +353,24 @@ isGlobal (LMGlobalVar _ _ _ _ _ _) = True
isGlobal _ = False
-- | Width in bits of an 'LlvmType', returns 0 if not applicable
-llvmWidthInBits :: DynFlags -> LlvmType -> Int
-llvmWidthInBits _ (LMInt n) = n
-llvmWidthInBits _ (LMFloat) = 32
-llvmWidthInBits _ (LMDouble) = 64
-llvmWidthInBits _ (LMFloat80) = 80
-llvmWidthInBits _ (LMFloat128) = 128
--- Could return either a pointer width here or the width of what
--- it points to. We will go with the former for now.
--- PMW: At least judging by the way LLVM outputs constants, pointers
--- should use the former, but arrays the latter.
-llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags)
-llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t
-llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty
-llvmWidthInBits _ LMLabel = 0
-llvmWidthInBits _ LMVoid = 0
-llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys
-llvmWidthInBits _ (LMStructU _) =
+llvmWidthInBits :: Platform -> LlvmType -> Int
+llvmWidthInBits platform = \case
+ (LMInt n) -> n
+ (LMFloat) -> 32
+ (LMDouble) -> 64
+ (LMFloat80) -> 80
+ (LMFloat128) -> 128
+ -- Could return either a pointer width here or the width of what
+ -- it points to. We will go with the former for now.
+ -- PMW: At least judging by the way LLVM outputs constants, pointers
+ -- should use the former, but arrays the latter.
+ (LMPointer _) -> llvmWidthInBits platform (llvmWord platform)
+ (LMArray n t) -> n * llvmWidthInBits platform t
+ (LMVector n ty) -> n * llvmWidthInBits platform ty
+ LMLabel -> 0
+ LMVoid -> 0
+ (LMStruct tys) -> sum $ map (llvmWidthInBits platform) tys
+ (LMStructU _) ->
-- It's not trivial to calculate the bit width of the unpacked structs,
-- since they will be aligned depending on the specified datalayout (
-- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support
@@ -377,9 +380,9 @@ llvmWidthInBits _ (LMStructU _) =
-- llvm.sadd.with.overflow.*), so we don't actually need to compute their
-- bit width.
panic "llvmWidthInBits: not implemented for LMStructU"
-llvmWidthInBits _ (LMFunction _) = 0
-llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t
-llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!"
+ (LMFunction _) -> 0
+ (LMAlias (_,t)) -> llvmWidthInBits platform t
+ LMMetadata -> panic "llvmWidthInBits: Meta-data has no runtime representation!"
-- -----------------------------------------------------------------------------
@@ -396,9 +399,9 @@ i1 = LMInt 1
i8Ptr = pLift i8
-- | The target architectures word size
-llvmWord, llvmWordPtr :: DynFlags -> LlvmType
-llvmWord dflags = LMInt (wORD_SIZE dflags * 8)
-llvmWordPtr dflags = pLift (llvmWord dflags)
+llvmWord, llvmWordPtr :: Platform -> LlvmType
+llvmWord platform = LMInt (platformWordSizeInBytes platform * 8)
+llvmWordPtr platform = pLift (llvmWord platform)
-- -----------------------------------------------------------------------------
-- * LLVM Function Types
diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs
index 8ef91ae741..c6a159345d 100644
--- a/compiler/GHC/Runtime/Heap/Layout.hs
+++ b/compiler/GHC/Runtime/Heap/Layout.hs
@@ -72,8 +72,8 @@ type ByteOff = Int
-- | Round up the given byte count to the next byte count that's a
-- multiple of the machine's word size.
-roundUpToWords :: DynFlags -> ByteOff -> ByteOff
-roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)
+roundUpToWords :: Platform -> ByteOff -> ByteOff
+roundUpToWords platform n = roundUpTo n (platformWordSizeInBytes platform)
-- | Round up @base@ to a multiple of @size@.
roundUpTo :: ByteOff -> ByteOff -> ByteOff
@@ -83,17 +83,17 @@ roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))
--
-- This function morally has type @WordOff -> ByteOff@, but uses @Num
-- a@ to allow for overloading.
-wordsToBytes :: Num a => DynFlags -> a -> a
-wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n
-{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}
-{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}
-{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}
+wordsToBytes :: Num a => Platform -> a -> a
+wordsToBytes platform n = fromIntegral (platformWordSizeInBytes platform) * n
+{-# SPECIALIZE wordsToBytes :: Platform -> Int -> Int #-}
+{-# SPECIALIZE wordsToBytes :: Platform -> Word -> Word #-}
+{-# SPECIALIZE wordsToBytes :: Platform -> Integer -> Integer #-}
-- | First round the given byte count up to a multiple of the
-- machine's word size and then convert the result to words.
-bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff
-bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size
- where word_size = wORD_SIZE dflags
+bytesToWordsRoundUp :: Platform -> ByteOff -> WordOff
+bytesToWordsRoundUp platform n = (n + word_size - 1) `quot` word_size
+ where word_size = platformWordSizeInBytes platform
-- StgWord is a type representing an StgWord on the target platform.
-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform
newtype StgWord = StgWord Word64
@@ -102,9 +102,9 @@ newtype StgWord = StgWord Word64
fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i
-toStgWord :: DynFlags -> Integer -> StgWord
-toStgWord dflags i
- = case platformWordSize (targetPlatform dflags) of
+toStgWord :: Platform -> Integer -> StgWord
+toStgWord platform i
+ = case platformWordSize platform of
-- These conversions mean that things like toStgWord (-1)
-- do the right thing
PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))
@@ -123,9 +123,9 @@ newtype StgHalfWord = StgHalfWord Word32
fromStgHalfWord :: StgHalfWord -> Integer
fromStgHalfWord (StgHalfWord w) = toInteger w
-toStgHalfWord :: DynFlags -> Integer -> StgHalfWord
-toStgHalfWord dflags i
- = case platformWordSize (targetPlatform dflags) of
+toStgHalfWord :: Platform -> Integer -> StgHalfWord
+toStgHalfWord platform i
+ = case platformWordSize platform of
-- These conversions mean that things like toStgHalfWord (-1)
-- do the right thing
PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))
@@ -135,11 +135,11 @@ instance Outputable StgHalfWord where
ppr (StgHalfWord w) = integer (toInteger w)
-- | Half word size in bytes
-halfWordSize :: DynFlags -> ByteOff
-halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2
+halfWordSize :: Platform -> ByteOff
+halfWordSize platform = platformWordSizeInBytes platform `div` 2
-halfWordSizeInBits :: DynFlags -> Int
-halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2
+halfWordSizeInBits :: Platform -> Int
+halfWordSizeInBits platform = platformWordSizeInBits platform `div` 2
{-
************************************************************************
@@ -255,8 +255,8 @@ arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
smallArrPtrsRep :: WordOff -> SMRep
smallArrPtrsRep elems = SmallArrayPtrsRep elems
-arrWordsRep :: DynFlags -> ByteOff -> SMRep
-arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)
+arrWordsRep :: Platform -> ByteOff -> SMRep
+arrWordsRep platform bytes = ArrayWordsRep (bytesToWordsRoundUp platform bytes)
-----------------------------------------------------------------------------
-- Predicates
@@ -297,7 +297,7 @@ isStaticNoCafCon _ = False
-- Size-related things
fixedHdrSize :: DynFlags -> ByteOff
-fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)
+fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags)
-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
fixedHdrSizeW :: DynFlags -> WordOff
@@ -322,7 +322,8 @@ arrWordsHdrSize dflags
arrWordsHdrSizeW :: DynFlags -> WordOff
arrWordsHdrSizeW dflags =
fixedHdrSizeW dflags +
- (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)
+ (sIZEOF_StgArrBytes_NoHdr dflags `quot`
+ platformWordSizeInBytes (targetPlatform dflags))
arrPtrsHdrSize :: DynFlags -> ByteOff
arrPtrsHdrSize dflags
@@ -331,7 +332,8 @@ arrPtrsHdrSize dflags
arrPtrsHdrSizeW :: DynFlags -> WordOff
arrPtrsHdrSizeW dflags =
fixedHdrSizeW dflags +
- (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+ (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot`
+ platformWordSizeInBytes (targetPlatform dflags))
smallArrPtrsHdrSize :: DynFlags -> ByteOff
smallArrPtrsHdrSize dflags
@@ -340,16 +342,18 @@ smallArrPtrsHdrSize dflags
smallArrPtrsHdrSizeW :: DynFlags -> WordOff
smallArrPtrsHdrSizeW dflags =
fixedHdrSizeW dflags +
- (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+ (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot`
+ platformWordSizeInBytes (targetPlatform dflags))
-- Thunks have an extra header word on SMP, so the update doesn't
-- splat the payload.
thunkHdrSize :: DynFlags -> WordOff
thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr
- where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags
+ where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot`
+ platformWordSizeInBytes (targetPlatform dflags)
hdrSize :: DynFlags -> SMRep -> ByteOff
-hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)
+hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep)
hdrSizeW :: DynFlags -> SMRep -> WordOff
hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty
@@ -358,8 +362,8 @@ hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags
hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags
hdrSizeW _ _ = panic "SMRep.hdrSizeW"
-nonHdrSize :: DynFlags -> SMRep -> ByteOff
-nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)
+nonHdrSize :: Platform -> SMRep -> ByteOff
+nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep)
nonHdrSizeW :: SMRep -> WordOff
nonHdrSizeW (HeapRep _ p np _) = p + np
@@ -413,7 +417,8 @@ cardTableSizeB dflags elems = cardRoundUp dflags elems
-- | The size of a card table, in words
cardTableSizeW :: DynFlags -> Int -> WordOff
cardTableSizeW dflags elems =
- bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)
+ bytesToWordsRoundUp (targetPlatform dflags)
+ (cardTableSizeB dflags elems)
-----------------------------------------------------------------------------
-- deriving the RTS closure type from an SMRep
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 1100cf4705..31ebdede81 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -188,6 +188,7 @@ cgDataCon :: DataCon -> FCode ()
-- the static closure, for a constructor.
cgDataCon data_con
= do { dflags <- getDynFlags
+ ; platform <- getPlatform
; let
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds) -- #ptr_wds
@@ -216,7 +217,7 @@ cgDataCon data_con
do { tickyEnterDynCon
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_reps)
- ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
+ ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)]
}
-- The case continuation code expects a tagged pointer
}
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 5116cc1a30..d1353fbecb 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -274,7 +274,7 @@ mkRhsClosure dflags bndr _cc
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
, Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
- , let offset_into_int = bytesToWordsRoundUp dflags the_offset
+ , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset
- fixedHdrSizeW dflags
, offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
= -- NOT TRUE: ASSERT(is_single_constructor)
@@ -479,6 +479,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
-- Emit slow-entry code (for entering a closure through a PAP)
{ mkSlowEntryCode bndr cl_info arg_regs
; dflags <- getDynFlags
+ ; platform <- getPlatform
; let node_points = nodeMustPointToIt dflags lf_info
node' = if node_points then Just node else Nothing
; loop_header_id <- newBlockId
@@ -494,9 +495,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
-- ticky after heap check to avoid double counting
; tickyEnterFun cl_info
; enterCostCentreFun cc
- (CmmMachOp (mo_wordSub dflags)
+ (CmmMachOp (mo_wordSub platform)
[ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
- , mkIntExpr dflags (funTag dflags cl_info) ])
+ , mkIntExpr platform (funTag dflags cl_info) ])
; fv_bindings <- mapM bind_fv fv_details
-- Load free vars out of closure *after*
-- heap check, to reduce live vars over check
@@ -526,8 +527,9 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs node lf_info = mapM_ (\ (reg, off) ->
do dflags <- getDynFlags
+ platform <- getPlatform
let tag = lfDynTag dflags lf_info
- emit $ mkTaggedObjectLoad dflags reg node off tag)
+ emit $ mkTaggedObjectLoad platform reg node off tag)
-----------------------------------------
-- The "slow entry" code for a function. This entry point takes its
@@ -545,14 +547,15 @@ mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
= do dflags <- getDynFlags
- let node = idToReg dflags (NonVoid bndr)
+ platform <- getPlatform
+ let node = idToReg platform (NonVoid bndr)
slow_lbl = closureSlowEntryLabel cl_info
fast_lbl = closureLocalEntryLabel dflags cl_info
-- mkDirectJump does not clobber `Node' containing function closure
jump = mkJump dflags NativeNodeCall
(mkLblExpr fast_lbl)
(map (CmmReg . CmmLocal) (node : arg_regs))
- (initUpdFrameOff dflags)
+ (initUpdFrameOff platform)
tscope <- getTickScope
emitProcWithConvention Slow Nothing slow_lbl
(node : arg_regs) (jump, tscope)
@@ -601,6 +604,7 @@ blackHoleIt node_reg
emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode node = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
-- Eager blackholing is normally disabled, but can be turned on with
-- -feager-blackholing. When it is on, we replace the info pointer
@@ -627,8 +631,8 @@ emitBlackHoleCode node = do
-- work with profiling.
when eager_blackholing $ do
- whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node
- emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
+ whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
+ emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr
-- See Note [Heap memory barriers] in SMP.h.
emitPrimCall [] MO_WriteBarrier []
emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
@@ -691,9 +695,10 @@ emitUpdateFrame dflags frame lbl updatee = do
let
hdr = fixedHdrSize dflags
off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
+ platform = targetPlatform dflags
--
emitStore frame (mkLblExpr lbl)
- emitStore (cmmOffset dflags frame off_updatee) updatee
+ emitStore (cmmOffset platform frame off_updatee) updatee
initUpdFrameProf frame
-----------------------------------------------------------------------------
@@ -711,7 +716,8 @@ link_caf node = do
-- blackhole indirection closure
; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
ForeignLabelInExternalPackage IsFunction
- ; bh <- newTemp (bWord dflags)
+ ; let platform = targetPlatform dflags
+ ; bh <- newTemp (bWord platform)
; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
[ (baseExpr, AddrHint),
(CmmReg (CmmLocal node), AddrHint) ]
@@ -721,7 +727,7 @@ link_caf node = do
; updfr <- getUpdFrameOff
; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))
; emit =<< mkCmmIfThen
- (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))
+ (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
-- re-enter the CAF
(mkJump dflags NativeNodeCall target [] updfr)
diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs
index 095e9c37df..7775cdf033 100644
--- a/compiler/GHC/StgToCmm/CgUtils.hs
+++ b/compiler/GHC/StgToCmm/CgUtils.hs
@@ -149,7 +149,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
| reg == MachSp -> stmt
| otherwise ->
let baseAddr = get_GlobalReg_addr dflags reg
- in case reg `elem` activeStgRegs (targetPlatform dflags) of
+ in case reg `elem` activeStgRegs platform of
True -> CmmAssign (CmmGlobal reg) src
False -> CmmStore baseAddr src
other_stmt -> other_stmt
@@ -170,7 +170,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
let baseAddr = get_GlobalReg_addr dflags reg
in case reg of
BaseReg -> baseAddr
- _other -> CmmLoad baseAddr (globalRegType dflags reg)
+ _other -> CmmLoad baseAddr (globalRegType platform reg)
CmmRegOff (CmmGlobal reg) offset ->
-- RegOf leaves are just a shorthand form. If the reg maps
@@ -178,9 +178,9 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
-- expand it and defer to the above code.
case reg `elem` activeStgRegs platform of
True -> expr
- False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+ False -> CmmMachOp (MO_Add (wordWidth platform)) [
fixExpr (CmmReg (CmmGlobal reg)),
CmmLit (CmmInt (fromIntegral offset)
- (wordWidth dflags))]
+ (wordWidth platform))]
other_expr -> other_expr
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 43e2ab8e9a..2da91879b3 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -198,7 +198,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
val_int = fromIntegral val :: Int
offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
-- INTLIKE closures consist of a header and one word payload
- intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
+ intlike_amode = cmmLabelOffW (targetPlatform dflags) intlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
, return mkNop) }
@@ -212,7 +212,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
= do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")
offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
-- CHARLIKE closures consist of a header and one word payload
- charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
+ charlike_amode = cmmLabelOffW (targetPlatform dflags) charlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
, return mkNop) }
@@ -256,6 +256,7 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs (DataAlt con) base args
= ASSERT(not (isUnboxedTupleCon con))
do dflags <- getDynFlags
+ platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
tag = tagForCon dflags con
@@ -266,7 +267,7 @@ bindConArgs (DataAlt con) base args
| isDeadBinder b -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr
= return Nothing
| otherwise
- = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)
+ = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg)
base offset tag
; Just <$> bindArgToReg arg }
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index fe886644c4..47c46eed63 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -27,6 +27,7 @@ module GHC.StgToCmm.Env (
import GhcPrelude
import GHC.Core.TyCon
+import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
@@ -60,14 +61,15 @@ mkCgIdInfo id lf expr
litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo dflags id lf lit
= CgIdInfo { cg_id = id, cg_lf = lf
- , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
+ , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }
where
tag = lfDynTag dflags lf
+ platform = targetPlatform dflags
-lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
-lneIdInfo dflags id regs
+lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
+lneIdInfo platform id regs
= CgIdInfo { cg_id = id, cg_lf = lf
- , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
+ , cg_loc = LneLoc blk_id (map (idToReg platform) regs) }
where
lf = mkLFLetNoEscape
blk_id = mkBlockId (idUnique id)
@@ -75,13 +77,14 @@ lneIdInfo dflags id regs
rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo id lf_info
- = do dflags <- getDynFlags
- reg <- newTemp (gcWord dflags)
+ = do platform <- getPlatform
+ reg <- newTemp (gcWord platform)
return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit dflags reg lf_info expr
- = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
+ = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info))
+ where platform = targetPlatform dflags
idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
@@ -89,9 +92,9 @@ idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
idInfoToAmode cg_info
= pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
-addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
--- A tag adds a byte offset to the pointer
-addDynTag dflags expr tag = cmmOffsetB dflags expr tag
+-- | A tag adds a byte offset to the pointer
+addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
+addDynTag platform expr tag = cmmOffsetB platform expr tag
maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
@@ -177,8 +180,8 @@ getNonVoidArgAmodes (arg:args)
bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
-- Bind an Id to a fresh LocalReg
bindToReg nvid@(NonVoid id) lf_info
- = do dflags <- getDynFlags
- let reg = idToReg dflags nvid
+ = do platform <- getPlatform
+ let reg = idToReg platform nvid
addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
return reg
@@ -195,7 +198,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs args = mapM bindArgToReg args
-idToReg :: DynFlags -> NonVoid Id -> LocalReg
+idToReg :: Platform -> NonVoid Id -> LocalReg
-- Make a register from an Id, typically a function argument,
-- free variable, or case binder
--
@@ -203,6 +206,6 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg
--
-- By now the Ids should be uniquely named; else one would worry
-- about accidental collision
-idToReg dflags (NonVoid id)
+idToReg platform (NonVoid id)
= LocalReg (idUnique id)
- (primRepCmmType dflags (idPrimRep id))
+ (primRepCmmType platform (idPrimRep id))
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 7f62c6dec1..9983a58616 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -72,8 +72,9 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
-- See Note [dataToTag#] in primops.txt.pp
cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
dflags <- getDynFlags
+ platform <- getPlatform
emitComment (mkFastString "dataToTag#")
- tmp <- newTemp (bWord dflags)
+ tmp <- newTemp (bWord platform)
_ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
-- TODO: For small types look at the tag bits instead of reading info table
emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
@@ -175,8 +176,8 @@ cgLetNoEscapeClosure
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
- = do dflags <- getDynFlags
- return ( lneIdInfo dflags bndr args
+ = do platform <- getPlatform
+ return ( lneIdInfo platform bndr args
, code )
where
code = forkLneBody $ do {
@@ -365,11 +366,12 @@ 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) $
pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
(pp_bndr v $$ pp_bndr bndr)
; v_info <- getCgIdInfo v
- ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
+ ; emitAssign (CmmLocal (idToReg platform (NonVoid bndr)))
(idInfoToAmode v_info)
-- Add bndr to the environment
; _ <- bindArgToReg (NonVoid bndr)
@@ -390,10 +392,10 @@ type-correct assignment, albeit bogus. The (dead) continuation loops;
it would be better to invoke some kind of panic function here.
-}
cgCase scrut@(StgApp v []) _ (PrimAlt _) _
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; mb_cc <- maybeSaveCostCentre True
; _ <- withSequel
- (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
+ (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut)
; restoreCurrentCostCentre mb_cc
; emitComment $ mkFastString "should be unreachable code"
; l <- newBlockId
@@ -425,10 +427,10 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
cgCase scrut bndr alt_type alts
= -- the general case
- do { dflags <- getDynFlags
+ do { platform <- getPlatform
; up_hp_usg <- getVirtHp -- Upstream heap usage
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
- alt_regs = map (idToReg dflags) ret_bndrs
+ alt_regs = map (idToReg platform) ret_bndrs
; simple_scrut <- isSimpleScrut scrut alt_type
; let do_gc | is_cmp_op scrut = False -- See Note [GC for conditionals]
| not simple_scrut = True
@@ -548,11 +550,11 @@ cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]
-- Here bndrs are *already* in scope, so don't rebind them
cgAlts gc_plan bndr (PrimAlt _) alts
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; tagged_cmms <- cgAltRhss gc_plan bndr alts
- ; let bndr_reg = CmmLocal (idToReg dflags bndr)
+ ; let bndr_reg = CmmLocal (idToReg platform bndr)
(DEFAULT,deflt) = head tagged_cmms
-- PrimAlts always have a DEFAULT case
-- and it always comes first
@@ -564,11 +566,12 @@ cgAlts gc_plan bndr (PrimAlt _) alts
cgAlts gc_plan bndr (AlgAlt tycon) alts
= do { dflags <- getDynFlags
+ ; platform <- getPlatform
; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
; let !fam_sz = tyConFamilySize tycon
- !bndr_reg = CmmLocal (idToReg dflags bndr)
+ !bndr_reg = CmmLocal (idToReg platform bndr)
!ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
!branches' = first succ <$> branches
!maxpt = mAX_PTR_TAG dflags
@@ -807,9 +810,9 @@ cgAlgAltRhss gc_plan bndr alts
cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss gc_plan bndr alts = do
- dflags <- getDynFlags
+ platform <- getPlatform
let
- base_reg = idToReg dflags bndr
+ base_reg = idToReg platform bndr
cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
cg_alt (con, bndrs, rhs)
= getCodeScoped $
@@ -1083,10 +1086,10 @@ emitEnter fun = do
-- simply pass on the annotation as a @CmmTickish@.
cgTick :: Tickish Id -> FCode ()
cgTick tick
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; case tick of
ProfNote cc t p -> emitSetCCC cc t p
- HpcTick m n -> emit (mkTickBox dflags m n)
+ HpcTick m n -> emit (mkTickBox platform m n)
SourceNote s n -> emitTick $ SourceNote s n
_other -> return () -- ignore
}
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index b083736b20..767e70939b 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -38,6 +38,7 @@ import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import ForeignCall
import GHC.Driver.Session
+import GHC.Platform
import Maybes
import Outputable
import UniqSupply
@@ -63,7 +64,7 @@ cgForeignCall :: ForeignCall -- the op
-> FCode ReturnKind
cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; let -- in the stdcall calling convention, the symbol needs @size appended
-- to it, where size is the total number of bytes of arguments. We
-- attach this info to the CLabel here, and the CLabel pretty printer
@@ -73,8 +74,8 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
| otherwise = Nothing
-- ToDo: this might not be correct for 64-bit API
- arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
- (wORD_SIZE dflags)
+ arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
+ (platformWordSizeInBytes platform)
; cmm_args <- getFCallArgs stg_args typ
; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
; let ((call_args, arg_hints), cmm_target)
@@ -222,6 +223,7 @@ emitForeignCall safety results target args
| otherwise = do
dflags <- getDynFlags
+ platform <- getPlatform
updfr_off <- getUpdFrameOff
target' <- load_target_into_temp target
args' <- mapM maybe_assign_temp args
@@ -230,7 +232,7 @@ emitForeignCall safety results target args
-- see Note [safe foreign call convention]
tscope <- getTickScope
emit $
- ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
+ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform)))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall { tgt = target'
, res = results
@@ -264,8 +266,8 @@ load_target_into_temp other_target@(PrimTarget _) =
--
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp e = do
- dflags <- getDynFlags
- reg <- newTemp (cmmExprType dflags e)
+ platform <- getPlatform
+ reg <- newTemp (cmmExprType platform e)
emitAssign (CmmLocal reg) e
return (CmmReg (CmmLocal reg))
@@ -284,30 +286,32 @@ emitSaveThreadState = do
-- | Produce code to save the current thread state to @CurrentTSO@
saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState dflags = do
- tso <- newTemp (gcWord dflags)
+ let platform = targetPlatform dflags
+ tso <- newTemp (gcWord platform)
close_nursery <- closeNursery dflags tso
pure $ catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) currentTSOExpr,
-- tso->stackobj->sp = Sp;
- mkStore (cmmOffset dflags
- (CmmLoad (cmmOffset dflags
+ mkStore (cmmOffset platform
+ (CmmLoad (cmmOffset platform
(CmmReg (CmmLocal tso))
(tso_stackobj dflags))
- (bWord dflags))
+ (bWord platform))
(stack_SP dflags))
spExpr,
close_nursery,
-- and save the current cost centre stack in the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then
- mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
+ mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
else mkNop
]
emitCloseNursery :: FCode ()
emitCloseNursery = do
dflags <- getDynFlags
- tso <- newTemp (bWord dflags)
+ platform <- getPlatform
+ tso <- newTemp (bWord platform)
code <- closeNursery dflags tso
emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
@@ -335,26 +339,27 @@ Closing the nursery corresponds to the following code:
closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
closeNursery df tso = do
let tsoreg = CmmLocal tso
- cnreg <- CmmLocal <$> newTemp (bWord df)
+ platform = targetPlatform df
+ cnreg <- CmmLocal <$> newTemp (bWord platform)
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
-- CurrentNursery->free = Hp+1;
- mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
+ mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1),
let alloc =
- CmmMachOp (mo_wordSub df)
- [ cmmOffsetW df hpExpr 1
- , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
+ CmmMachOp (mo_wordSub platform)
+ [ cmmOffsetW platform hpExpr 1
+ , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform)
]
- alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+ alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df)
in
-- tso->alloc_limit += alloc
mkStore alloc_limit (CmmMachOp (MO_Sub W64)
[ CmmLoad alloc_limit b64
- , CmmMachOp (mo_WordTo64 df) [alloc] ])
+ , CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
emitLoadThreadState :: FCode ()
@@ -366,29 +371,30 @@ emitLoadThreadState = do
-- | Produce code to load the current thread state from @CurrentTSO@
loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState dflags = do
- tso <- newTemp (gcWord dflags)
- stack <- newTemp (gcWord dflags)
+ let platform = targetPlatform dflags
+ tso <- newTemp (gcWord platform)
+ stack <- newTemp (gcWord platform)
open_nursery <- openNursery dflags tso
pure $ catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) currentTSOExpr,
-- stack = tso->stackobj;
- mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
+ mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)),
-- Sp = stack->sp;
- mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+ mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)),
-- SpLim = stack->stack + RESERVED_STACK_WORDS;
- mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
+ mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
- mkAssign hpAllocReg (zeroExpr dflags),
+ mkAssign hpAllocReg (zeroExpr platform),
open_nursery,
-- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags
then storeCurCCS
- (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
- (tso_CCCS dflags)) (ccsType dflags))
+ (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))
+ (tso_CCCS dflags)) (ccsType platform))
else mkNop
]
@@ -396,7 +402,8 @@ loadThreadState dflags = do
emitOpenNursery :: FCode ()
emitOpenNursery = do
dflags <- getDynFlags
- tso <- newTemp (bWord dflags)
+ platform <- getPlatform
+ tso <- newTemp (bWord platform)
code <- openNursery dflags tso
emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
@@ -429,11 +436,12 @@ Opening the nursery corresponds to the following code:
@
-}
openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
-openNursery df tso = do
+openNursery dflags tso = do
let tsoreg = CmmLocal tso
- cnreg <- CmmLocal <$> newTemp (bWord df)
- bdfreereg <- CmmLocal <$> newTemp (bWord df)
- bdstartreg <- CmmLocal <$> newTemp (bWord df)
+ platform = targetPlatform dflags
+ cnreg <- CmmLocal <$> newTemp (bWord platform)
+ bdfreereg <- CmmLocal <$> newTemp (bWord platform)
+ bdstartreg <- CmmLocal <$> newTemp (bWord platform)
-- These assignments are carefully ordered to reduce register
-- pressure and generate not completely awful code on x86. To see
@@ -441,23 +449,23 @@ openNursery df tso = do
-- stg_returnToStackTop in rts/StgStartup.cmm.
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
- mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)),
+ mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)),
-- Hp = CurrentNursery->free - 1;
- mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+ mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)),
- mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
+ mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)),
-- HpLim = CurrentNursery->start +
-- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
mkAssign hpLimReg
- (cmmOffsetExpr df
+ (cmmOffsetExpr platform
(CmmReg bdstartreg)
- (cmmOffset df
- (CmmMachOp (mo_wordMul df) [
- CmmMachOp (MO_SS_Conv W32 (wordWidth df))
- [CmmLoad (nursery_bdescr_blocks df cnreg) b32],
- mkIntExpr df (bLOCK_SIZE df)
+ (cmmOffset platform
+ (CmmMachOp (mo_wordMul platform) [
+ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))
+ [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32],
+ mkIntExpr platform (bLOCK_SIZE dflags)
])
(-1)
)
@@ -465,26 +473,26 @@ openNursery df tso = do
-- alloc = bd->free - bd->start
let alloc =
- CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
+ CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg]
- alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+ alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags)
in
-- tso->alloc_limit += alloc
mkStore alloc_limit (CmmMachOp (MO_Add W64)
[ CmmLoad alloc_limit b64
- , CmmMachOp (mo_WordTo64 df) [alloc] ])
+ , CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
:: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free dflags cn =
- cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
+ cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags)
nursery_bdescr_start dflags cn =
- cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
+ cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags)
nursery_bdescr_blocks dflags cn =
- cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)
+ cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags)
tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
@@ -583,9 +591,11 @@ data StgFArgType
add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
add_shim dflags ty expr = case ty of
StgPlainType -> expr
- StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
- StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
- StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+ StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags)
+ StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags)
+ StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags)
+ where
+ platform = targetPlatform dflags
-- From a function, extract information needed to determine
-- the offset of each argument when used as a C FFI argument.
diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs
index d1b1752fd3..21388d81cb 100644
--- a/compiler/GHC/StgToCmm/Heap.hs
+++ b/compiler/GHC/StgToCmm/Heap.hs
@@ -46,6 +46,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs )
import Id ( Id )
import Module
import GHC.Driver.Session
+import GHC.Platform
import FastString( mkFastString, fsLit )
import Panic( sorry )
@@ -153,9 +154,9 @@ emitSetDynHdr base info_ptr ccs
-- Store the item (expr,off) in base[off]
hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
hpStore base vals = do
- dflags <- getDynFlags
+ platform <- getPlatform
sequence_ $
- [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]
+ [ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ]
-----------------------------------------------------------
-- Layout of static closures
@@ -175,6 +176,7 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
= mkStaticClosure dflags info_lbl ccs payload padding
static_link_field saved_info_field
where
+ platform = targetPlatform dflags
info_lbl = cit_lbl info_tbl
-- CAFs must have consistent layout, regardless of whether they
@@ -192,27 +194,27 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
is_caf = isThunkRep (cit_rep info_tbl)
padding
- | is_caf && null payload = [mkIntCLit dflags 0]
+ | is_caf && null payload = [mkIntCLit platform 0]
| otherwise = []
static_link_field
| is_caf
- = [mkIntCLit dflags 0]
+ = [mkIntCLit platform 0]
| staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
= [static_link_value]
| otherwise
= []
saved_info_field
- | is_caf = [mkIntCLit dflags 0]
+ | is_caf = [mkIntCLit platform 0]
| otherwise = []
-- For a static constructor which has NoCafRefs, we set the
-- static link field to a non-zero value so the garbage
-- collector will ignore it.
static_link_value
- | mayHaveCafRefs caf_refs = mkIntCLit dflags 0
- | otherwise = mkIntCLit dflags 3 -- No CAF refs
+ | mayHaveCafRefs caf_refs = mkIntCLit platform 0
+ | otherwise = mkIntCLit platform 3 -- No CAF refs
-- See Note [STATIC_LINK fields]
-- in rts/sm/Storage.h
@@ -402,7 +404,8 @@ altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
altOrNoEscapeHeapCheck checkYield regs code = do
dflags <- getDynFlags
- case cannedGCEntryPoint dflags regs of
+ platform <- getPlatform
+ case cannedGCEntryPoint platform regs of
Nothing -> genericGC checkYield code
Just gc -> do
lret <- newBlockId
@@ -415,8 +418,8 @@ altOrNoEscapeHeapCheck checkYield regs code = do
altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
altHeapCheckReturnsTo regs lret off code
- = do dflags <- getDynFlags
- case cannedGCEntryPoint dflags regs of
+ = do platform <- getPlatform
+ case cannedGCEntryPoint platform regs of
Nothing -> genericGC False code
Just gc -> cannedGCReturnsTo False True gc regs lret off code
@@ -455,8 +458,8 @@ genericGC checkYield code
call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
heapCheck False checkYield (call <*> mkBranch lretry) code
-cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
-cannedGCEntryPoint dflags regs
+cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
+cannedGCEntryPoint platform regs
= case map localRegType regs of
[] -> Just (mkGcLabel "stg_gc_noregs")
[ty]
@@ -466,9 +469,9 @@ cannedGCEntryPoint dflags regs
W64 -> Just (mkGcLabel "stg_gc_d1")
_ -> Nothing
- | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
- | width == W64 -> Just (mkGcLabel "stg_gc_l1")
- | otherwise -> Nothing
+ | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1")
+ | width == W64 -> Just (mkGcLabel "stg_gc_l1")
+ | otherwise -> Nothing
where
width = typeWidth ty
[ty1,ty2]
@@ -518,6 +521,7 @@ heapCheck checkStack checkYield do_gc code
-- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
do { dflags <- getDynFlags
+ ; platform <- getPlatform
; let mb_alloc_bytes
| hpHw > mBLOCK_SIZE = sorry $ unlines
[" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",
@@ -526,7 +530,7 @@ heapCheck checkStack checkYield do_gc code
"See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
"Suggestion: read data from a file instead of having large static data",
"structures in code."]
- | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
+ | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform)))
| otherwise = Nothing
where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags
stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
@@ -598,26 +602,27 @@ do_checks :: Maybe CmmExpr -- Should we check the stack?
-> FCode ()
do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
dflags <- getDynFlags
+ platform <- getPlatform
gc_id <- newBlockId
let
Just alloc_lit = mb_alloc_lit
- bump_hp = cmmOffsetExprB dflags hpExpr alloc_lit
+ bump_hp = cmmOffsetExprB platform hpExpr alloc_lit
-- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
-- At the beginning of a function old + 0 = Sp
-- See Note [Single stack check]
sp_oflo sp_hwm =
- CmmMachOp (mo_wordULt dflags)
- [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
+ CmmMachOp (mo_wordULt platform)
+ [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg)))
[CmmStackSlot Old 0, sp_hwm],
CmmReg spLimReg]
-- Hp overflow if (Hp > HpLim)
-- (Hp has been incremented by now)
-- HpLim points to the LAST WORD of valid allocation space.
- hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]
+ hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr]
alloc_n = mkAssign hpAllocReg alloc_lit
@@ -643,9 +648,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
else do
when (checkYield && not (gopt Opt_OmitYields dflags)) $ do
-- Yielding if HpLim == 0
- let yielding = CmmMachOp (mo_wordEq dflags)
+ let yielding = CmmMachOp (mo_wordEq platform)
[CmmReg hpLimReg,
- CmmLit (zeroCLit dflags)]
+ CmmLit (zeroCLit platform)]
emit =<< mkCmmIfGoto' yielding gc_id (Just False)
tscope <- getTickScope
diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs
index d52ff3fa93..886c0e12e8 100644
--- a/compiler/GHC/StgToCmm/Hpc.hs
+++ b/compiler/GHC/StgToCmm/Hpc.hs
@@ -12,6 +12,7 @@ import GhcPrelude
import GHC.StgToCmm.Monad
+import GHC.Platform
import GHC.Cmm.Graph
import GHC.Cmm.Expr
import GHC.Cmm.CLabel
@@ -23,14 +24,14 @@ import GHC.Driver.Session
import Control.Monad
-mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph
-mkTickBox dflags mod n
+mkTickBox :: Platform -> Module -> Int -> CmmAGraph
+mkTickBox platform mod n
= mkStore tick_box (CmmMachOp (MO_Add W64)
[ CmmLoad tick_box b64
, CmmLit (CmmInt 1 W64)
])
where
- tick_box = cmmIndex dflags W64
+ tick_box = cmmIndex platform W64
(CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
n
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index cf2024fa31..93aeabb8a9 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -53,6 +53,7 @@ import Id
import GHC.Core.TyCon ( PrimRep(..), primRepSizeB )
import BasicTypes ( RepArity )
import GHC.Driver.Session
+import GHC.Platform
import Module
import Util
@@ -78,12 +79,13 @@ import Control.Monad
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn results
= do { dflags <- getDynFlags
+ ; platform <- getPlatform
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; case sequel of
Return ->
do { adjustHpBackwards
- ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
+ ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)
; emit (mkReturn dflags (entryCode dflags e) results updfr_off)
}
AssignTo regs adjust ->
@@ -189,6 +191,7 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
-- (slowCall fun args) applies fun to args, returning the results to Sequel
slowCall fun stg_args
= do dflags <- getDynFlags
+ platform <- getPlatform
argsreps <- getArgRepsAmodes stg_args
let (rts_fun, arity) = slowCallPattern (map fst argsreps)
@@ -227,8 +230,8 @@ slowCall fun stg_args
is_tagged_lbl <- newBlockId
end_lbl <- newBlockId
- let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
- (mkIntExpr dflags n_args)
+ let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr)
+ (mkIntExpr platform n_args)
tscope <- getTickScope
emit (mkCbranch (cmmIsTagged dflags funv)
@@ -389,9 +392,9 @@ hpRel hp off = off - hp
getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
-- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad
getHpRelOffset virtual_offset
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
hp_usg <- getHpUsage
- return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
+ return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset))
data FieldOffOrPadding a
= FieldOff (NonVoid a) -- Something that needs an offset.
@@ -426,15 +429,16 @@ mkVirtHeapOffsetsWithPadding
mkVirtHeapOffsetsWithPadding dflags header things =
ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
( tot_wds
- , bytesToWordsRoundUp dflags bytes_of_ptrs
+ , bytesToWordsRoundUp platform bytes_of_ptrs
, concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
)
where
+ platform = targetPlatform dflags
hdr_words = case header of
NoHeader -> 0
StdHeader -> fixedHdrSizeW dflags
ThunkHeader -> thunkHdrSize dflags
- hdr_bytes = wordsToBytes dflags hdr_words
+ hdr_bytes = wordsToBytes platform hdr_words
(ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
@@ -443,7 +447,7 @@ mkVirtHeapOffsetsWithPadding dflags header things =
(tot_bytes, non_ptrs_w_offsets) =
mapAccumL computeOffset bytes_of_ptrs non_ptrs
- tot_wds = bytesToWordsRoundUp dflags tot_bytes
+ tot_wds = bytesToWordsRoundUp platform tot_bytes
final_pad_size = tot_wds * word_size - tot_bytes
final_pad
@@ -451,7 +455,7 @@ mkVirtHeapOffsetsWithPadding dflags header things =
(hdr_bytes + tot_bytes))]
| otherwise = []
- word_size = wORD_SIZE dflags
+ word_size = platformWordSizeInBytes platform
computeOffset bytes_so_far nv_thing =
(new_bytes_so_far, with_padding field_off)
@@ -598,10 +602,11 @@ emitClosureProcAndInfoTable :: Bool -- top-level?
-> FCode ()
emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
= do { dflags <- getDynFlags
+ ; platform <- getPlatform
-- Bind the binder itself, but only if it's not a top-level
-- binding. We need non-top let-bindings to refer to the
-- top-level binding, which this binding would incorrectly shadow.
- ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
+ ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)
else bindToReg (NonVoid bndr) lf_info
; let node_points = nodeMustPointToIt dflags lf_info
; arg_regs <- bindArgsToRegs args
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index ce01ffdb29..9edff8bd66 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -22,7 +22,7 @@ module GHC.StgToCmm.Monad (
emitOutOfLine, emitAssign, emitStore,
emitComment, emitTick, emitUnwind,
- getCmm, aGraphToGraph,
+ getCmm, aGraphToGraph, getPlatform,
getCodeR, getCode, getCodeScoped, getHeapUsage,
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
@@ -61,6 +61,7 @@ module GHC.StgToCmm.Monad (
import GhcPrelude hiding( sequence, succ )
+import GHC.Platform
import GHC.Cmm
import GHC.StgToCmm.Closure
import GHC.Driver.Session
@@ -276,7 +277,7 @@ initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags
, cgd_mod = mod
- , cgd_updfr_off = initUpdFrameOff dflags
+ , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags)
, cgd_ticky = mkTopTickyCtrLabel
, cgd_sequel = initSequel
, cgd_self_loop = Nothing
@@ -285,8 +286,8 @@ initCgInfoDown dflags mod
initSequel :: Sequel
initSequel = Return
-initUpdFrameOff :: DynFlags -> UpdFrameOffset
-initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
+initUpdFrameOff :: Platform -> UpdFrameOffset
+initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA
--------------------------------------------------------
@@ -470,6 +471,9 @@ withSelfLoop self_loop code = do
instance HasDynFlags FCode where
getDynFlags = liftM cgd_dflags getInfoDown
+getPlatform :: FCode Platform
+getPlatform = targetPlatform <$> getDynFlags
+
getThisPackage :: FCode UnitId
getThisPackage = liftM thisPackage getDynFlags
@@ -562,12 +566,12 @@ forkClosureBody :: FCode () -> FCode ()
-- re-bind the free variables to a field of the closure.
forkClosureBody body_code
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let body_info_down = info { cgd_sequel = initSequel
- , cgd_updfr_off = initUpdFrameOff dflags
+ , cgd_updfr_off = initUpdFrameOff platform
, cgd_self_loop = Nothing }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out) = doFCode body_code body_info_down fork_state_in
@@ -736,8 +740,8 @@ emitProcWithStackFrame
-> FCode ()
emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
- = do { dflags <- getDynFlags
- ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
+ = do { platform <- getPlatform
+ ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False
}
emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
-- do layout
@@ -758,7 +762,7 @@ emitProcWithConvention conv mb_info lbl args blocks
emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
-> Int -> Bool -> FCode ()
emitProc mb_info lbl live blocks offset do_layout
- = do { dflags <- getDynFlags
+ = do { platform <- getPlatform
; l <- newBlockId
; let
blks :: CmmGraph
@@ -768,7 +772,7 @@ emitProc mb_info lbl live blocks offset do_layout
| otherwise = mapEmpty
sinfo = StackInfo { arg_space = offset
- , updfr_space = Just (initUpdFrameOff dflags)
+ , updfr_space = Just (initUpdFrameOff platform)
, do_layout = do_layout }
tinfo = TopInfo { info_tbls = infos
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 2555d764db..de3adc7697 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -100,8 +100,8 @@ cgOpApp (StgPrimOp primop) args res_ty = do
emitReturn []
| ReturnsPrim rep <- result_info
- -> do dflags <- getDynFlags
- res <- newTemp (primRepCmmType dflags rep)
+ -> do platform <- getPlatform
+ res <- newTemp (primRepCmmType platform rep)
f [res]
emitReturn [CmmReg (CmmLocal res)]
@@ -176,11 +176,11 @@ emitPrimOp dflags = \case
NewArrayOp -> \case
[(CmmLit (CmmInt n w)), init]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
- [ (mkIntExpr dflags (fromInteger n),
+ [ (mkIntExpr platform (fromInteger n),
fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)
- , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
+ , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)
]
(fromInteger n) init
@@ -208,34 +208,34 @@ emitPrimOp dflags = \case
CloneArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
CloneMutableArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
FreezeArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
ThawArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
NewSmallArrayOp -> \case
[(CmmLit (CmmInt n w)), init]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] ->
doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
- [ (mkIntExpr dflags (fromInteger n),
+ [ (mkIntExpr platform (fromInteger n),
fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
]
(fromInteger n) init
@@ -253,25 +253,25 @@ emitPrimOp dflags = \case
CloneSmallArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
CloneSmallMutableArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
FreezeSmallArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
ThawSmallArrayOp -> \case
[src, src_off, (CmmLit (CmmInt n w))]
- | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
+ | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
@@ -290,7 +290,7 @@ emitPrimOp dflags = \case
-- refer to arg twice (once to pass to newSpark(), and once to
-- assign to res), so put it in a temporary.
tmp <- assignTemp arg
- tmp2 <- newTemp (bWord dflags)
+ tmp2 <- newTemp (bWord platform)
emitCCall
[(tmp2,NoHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
@@ -301,7 +301,7 @@ emitPrimOp dflags = \case
let
val
| gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
- | otherwise = CmmLit (zeroCLit dflags)
+ | otherwise = CmmLit (zeroCLit platform)
emitAssign (CmmLocal res) val
GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do
@@ -311,11 +311,11 @@ emitPrimOp dflags = \case
emitAssign (CmmLocal res) currentTSOExpr
ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do
- emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
+ emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))
WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do
- old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)
- emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
+ old_val <- CmmLocal <$> newTemp (cmmExprType platform var)
+ emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))
-- Without this write barrier, other CPUs may see this pointer before
-- the writes for the closure it points to have occurred.
@@ -323,7 +323,7 @@ emitPrimOp dflags = \case
-- that the read of old_val comes before another core's write to the
-- MutVar's value.
emitPrimCall res MO_WriteBarrier []
- emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
+ emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
@@ -332,7 +332,7 @@ emitPrimOp dflags = \case
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
- emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+ emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))
-- #define sizzeofMutableByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
@@ -341,7 +341,7 @@ emitPrimOp dflags = \case
-- #define getSizzeofMutableByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
- emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+ emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))
-- #define touchzh(o) /* nothing */
@@ -350,14 +350,14 @@ emitPrimOp dflags = \case
-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do
- emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
+ emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags))
-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do
- emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+ emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))
ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do
- emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
+ emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])
-- #define addrToHValuezh(r,a) r=(P_)a
AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do
@@ -434,17 +434,17 @@ emitPrimOp dflags = \case
-- Getting the size of pointer arrays
SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do
- emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg
- (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))
- (bWord dflags))
+ emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg
+ (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags))
+ (bWord platform))
SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp
SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp
SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp
SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do
emit $ mkAssign (CmmLocal res)
- (cmmLoadIndexW dflags arg
- (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
- (bWord dflags))
+ (cmmLoadIndexW platform arg
+ (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
+ (bWord platform))
SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp
GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp
@@ -452,281 +452,281 @@ emitPrimOp dflags = \case
-- IndexXXXoffAddr
IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args
IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args
IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing f32 res args
IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing f64 res args
IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args
IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+ doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args
IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args
IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing b64 res args
IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args
IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+ doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args
IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args
IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing b64 res args
-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args
ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args
ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing f32 res args
ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing f64 res args
ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp Nothing (bWord dflags) res args
+ doIndexOffAddrOp Nothing (bWord platform) res args
ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_s_8ToWord platform)) b8 res args
ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+ doIndexOffAddrOp (Just (mo_s_16ToWord platform)) b16 res args
ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_s_32ToWord platform)) b32 res args
ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing b64 res args
ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexOffAddrOp (Just (mo_u_8ToWord platform)) b8 res args
ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+ doIndexOffAddrOp (Just (mo_u_16ToWord platform)) b16 res args
ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
- doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexOffAddrOp (Just (mo_u_32ToWord platform)) b32 res args
ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
doIndexOffAddrOp Nothing b64 res args
-- IndexXXXArray
IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args
IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args
IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing f32 res args
IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing f64 res args
IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args
IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+ doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args
IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args
IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing b64 res args
IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args
IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+ doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args
IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args
IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing b64 res args
-- ReadXXXArray, identical to IndexXXXArray.
ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args
ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args
ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing f32 res args
ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing f64 res args
ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp Nothing (bWord dflags) res args
+ doIndexByteArrayOp Nothing (bWord platform) res args
ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_s_8ToWord platform)) b8 res args
ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+ doIndexByteArrayOp (Just (mo_s_16ToWord platform)) b16 res args
ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_s_32ToWord platform)) b32 res args
ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing b64 res args
ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+ doIndexByteArrayOp (Just (mo_u_8ToWord platform)) b8 res args
ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+ doIndexByteArrayOp (Just (mo_u_16ToWord platform)) b16 res args
ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
+ doIndexByteArrayOp (Just (mo_u_32ToWord platform)) b32 res args
ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOp Nothing b64 res args
-- IndexWord8ArrayAsXXX
IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_8ToWord dflags)) b8 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args
IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args
IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing f32 b8 res args
IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing f64 b8 res args
IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_s_16ToWord dflags)) b16 b8 res args
+ doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args
IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_s_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args
IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing b64 b8 res args
IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_16ToWord dflags)) b16 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args
IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args
IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing b64 b8 res args
-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_8ToWord dflags)) b8 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args
ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args
ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing f32 b8 res args
ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing f64 b8 res args
ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs Nothing (bWord dflags) b8 res args
+ doIndexByteArrayOpAs Nothing (bWord platform) b8 res args
ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_s_16ToWord dflags)) b16 b8 res args
+ doIndexByteArrayOpAs (Just (mo_s_16ToWord platform)) b16 b8 res args
ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_s_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_s_32ToWord platform)) b32 b8 res args
ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing b64 b8 res args
ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_16ToWord dflags)) b16 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_16ToWord platform)) b16 b8 res args
ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
- doIndexByteArrayOpAs (Just (mo_u_32ToWord dflags)) b32 b8 res args
+ doIndexByteArrayOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args
ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
doIndexByteArrayOpAs Nothing b64 b8 res args
-- WriteXXXoffAddr
WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args
WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args
WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp Nothing (bWord dflags) res args
+ doWriteOffAddrOp Nothing (bWord platform) res args
WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp Nothing (bWord dflags) res args
+ doWriteOffAddrOp Nothing (bWord platform) res args
WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp Nothing (bWord dflags) res args
+ doWriteOffAddrOp Nothing (bWord platform) res args
WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do
doWriteOffAddrOp Nothing f32 res args
WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do
doWriteOffAddrOp Nothing f64 res args
WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp Nothing (bWord dflags) res args
+ doWriteOffAddrOp Nothing (bWord platform) res args
WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args
WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+ doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args
WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args
WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do
doWriteOffAddrOp Nothing b64 res args
WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args
WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+ doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args
WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do
- doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args
WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do
doWriteOffAddrOp Nothing b64 res args
-- WriteXXXArray
WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args
WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args
WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp Nothing (bWord dflags) res args
+ doWriteByteArrayOp Nothing (bWord platform) res args
WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp Nothing (bWord dflags) res args
+ doWriteByteArrayOp Nothing (bWord platform) res args
WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp Nothing (bWord dflags) res args
+ doWriteByteArrayOp Nothing (bWord platform) res args
WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing f32 res args
WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing f64 res args
WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp Nothing (bWord dflags) res args
+ doWriteByteArrayOp Nothing (bWord platform) res args
WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args
WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+ doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args
WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args
WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b64 res args
WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args
WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+ doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args
WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args
WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b64 res args
-- WriteInt8ArrayAsXXX
WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo8 platform)) b8 res args
WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args
WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b8 res args
WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do
@@ -740,15 +740,15 @@ emitPrimOp dflags = \case
WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b8 res args
WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args
WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args
WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b8 res args
WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args
WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do
- doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+ doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args
WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do
doWriteByteArrayOp Nothing b8 res args
@@ -777,7 +777,7 @@ emitPrimOp dflags = \case
BSwap64Op -> \[w] -> opAllDone $ \[res] -> do
emitBSwapCall res w W64
BSwapOp -> \[w] -> opAllDone $ \[res] -> do
- emitBSwapCall res w (wordWidth dflags)
+ emitBSwapCall res w (wordWidth platform)
BRev8Op -> \[w] -> opAllDone $ \[res] -> do
emitBRevCall res w W8
@@ -788,7 +788,7 @@ emitPrimOp dflags = \case
BRev64Op -> \[w] -> opAllDone $ \[res] -> do
emitBRevCall res w W64
BRevOp -> \[w] -> opAllDone $ \[res] -> do
- emitBRevCall res w (wordWidth dflags)
+ emitBRevCall res w (wordWidth platform)
-- Population count
PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do
@@ -800,7 +800,7 @@ emitPrimOp dflags = \case
PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do
emitPopCntCall res w W64
PopCntOp -> \[w] -> opAllDone $ \[res] -> do
- emitPopCntCall res w (wordWidth dflags)
+ emitPopCntCall res w (wordWidth platform)
-- Parallel bit deposit
Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do
@@ -812,7 +812,7 @@ emitPrimOp dflags = \case
Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do
emitPdepCall res src mask W64
PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do
- emitPdepCall res src mask (wordWidth dflags)
+ emitPdepCall res src mask (wordWidth platform)
-- Parallel bit extract
Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do
@@ -824,7 +824,7 @@ emitPrimOp dflags = \case
Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do
emitPextCall res src mask W64
PextOp -> \[src, mask] -> opAllDone $ \[res] -> do
- emitPextCall res src mask (wordWidth dflags)
+ emitPextCall res src mask (wordWidth platform)
-- count leading zeros
Clz8Op -> \[w] -> opAllDone $ \[res] -> do
@@ -836,7 +836,7 @@ emitPrimOp dflags = \case
Clz64Op -> \[w] -> opAllDone $ \[res] -> do
emitClzCall res w W64
ClzOp -> \[w] -> opAllDone $ \[res] -> do
- emitClzCall res w (wordWidth dflags)
+ emitClzCall res w (wordWidth platform)
-- count trailing zeros
Ctz8Op -> \[w] -> opAllDone $ \[res] -> do
@@ -848,7 +848,7 @@ emitPrimOp dflags = \case
Ctz64Op -> \[w] -> opAllDone $ \[res] -> do
emitCtzCall res w W64
CtzOp -> \[w] -> opAllDone $ \[res] -> do
- emitCtzCall res w (wordWidth dflags)
+ emitCtzCall res w (wordWidth platform)
-- Unsigned int to floating point conversions
Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do
@@ -859,7 +859,7 @@ emitPrimOp dflags = \case
-- SIMD primops
(VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do
checkVecCompatibility dflags vcat n w
- doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res
+ doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res
where
zeros :: CmmExpr
zeros = CmmLit $ CmmVec (replicate n zero)
@@ -877,7 +877,7 @@ emitPrimOp dflags = \case
checkVecCompatibility dflags vcat n w
when (es `lengthIsNot` n) $
panic "emitPrimOp: VecPackOp has wrong number of arguments"
- doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res
+ doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res
where
zeros :: CmmExpr
zeros = CmmLit $ CmmVec (replicate n zero)
@@ -895,14 +895,14 @@ emitPrimOp dflags = \case
checkVecCompatibility dflags vcat n w
when (res `lengthIsNot` n) $
panic "emitPrimOp: VecUnpackOp has wrong number of results"
- doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res
+ doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res
where
ty :: CmmType
ty = vecVmmType vcat n w
(VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do
checkVecCompatibility dflags vcat n w
- doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res
+ doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res
where
ty :: CmmType
ty = vecVmmType vcat n w
@@ -1041,23 +1041,23 @@ emitPrimOp dflags = \case
-- Atomic read-modify-write
FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_Add mba ix (bWord dflags) n
+ doAtomicRMW res AMO_Add mba ix (bWord platform) n
FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_Sub mba ix (bWord dflags) n
+ doAtomicRMW res AMO_Sub mba ix (bWord platform) n
FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_And mba ix (bWord dflags) n
+ doAtomicRMW res AMO_And mba ix (bWord platform) n
FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_Nand mba ix (bWord dflags) n
+ doAtomicRMW res AMO_Nand mba ix (bWord platform) n
FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_Or mba ix (bWord dflags) n
+ doAtomicRMW res AMO_Or mba ix (bWord platform) n
FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do
- doAtomicRMW res AMO_Xor mba ix (bWord dflags) n
+ doAtomicRMW res AMO_Xor mba ix (bWord platform) n
AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do
- doAtomicReadByteArray res mba ix (bWord dflags)
+ doAtomicReadByteArray res mba ix (bWord platform)
AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do
- doAtomicWriteByteArray mba ix (bWord dflags) val
+ doAtomicWriteByteArray mba ix (bWord platform) val
CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do
- doCasByteArray res mba ix (bWord dflags) old new
+ doCasByteArray res mba ix (bWord platform) old new
-- The rest just translate straightforwardly
@@ -1068,12 +1068,12 @@ emitPrimOp dflags = \case
ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same
OrdOp -> \args -> opNop args
- Narrow8IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W8)
- Narrow16IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W16)
- Narrow32IntOp -> \args -> opNarrow dflags args (MO_SS_Conv, W32)
- Narrow8WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W8)
- Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16)
- Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32)
+ Narrow8IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W8)
+ Narrow16IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W16)
+ Narrow32IntOp -> \args -> opNarrow platform args (MO_SS_Conv, W32)
+ Narrow8WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W8)
+ Narrow16WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W16)
+ Narrow32WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W32)
DoublePowerOp -> \args -> opCallish args MO_F64_Pwr
DoubleSinOp -> \args -> opCallish args MO_F64_Sin
@@ -1115,70 +1115,70 @@ emitPrimOp dflags = \case
-- Native word signless ops
- IntAddOp -> \args -> opTranslate args (mo_wordAdd dflags)
- IntSubOp -> \args -> opTranslate args (mo_wordSub dflags)
- WordAddOp -> \args -> opTranslate args (mo_wordAdd dflags)
- WordSubOp -> \args -> opTranslate args (mo_wordSub dflags)
- AddrAddOp -> \args -> opTranslate args (mo_wordAdd dflags)
- AddrSubOp -> \args -> opTranslate args (mo_wordSub dflags)
-
- IntEqOp -> \args -> opTranslate args (mo_wordEq dflags)
- IntNeOp -> \args -> opTranslate args (mo_wordNe dflags)
- WordEqOp -> \args -> opTranslate args (mo_wordEq dflags)
- WordNeOp -> \args -> opTranslate args (mo_wordNe dflags)
- AddrEqOp -> \args -> opTranslate args (mo_wordEq dflags)
- AddrNeOp -> \args -> opTranslate args (mo_wordNe dflags)
-
- AndOp -> \args -> opTranslate args (mo_wordAnd dflags)
- OrOp -> \args -> opTranslate args (mo_wordOr dflags)
- XorOp -> \args -> opTranslate args (mo_wordXor dflags)
- NotOp -> \args -> opTranslate args (mo_wordNot dflags)
- SllOp -> \args -> opTranslate args (mo_wordShl dflags)
- SrlOp -> \args -> opTranslate args (mo_wordUShr dflags)
-
- AddrRemOp -> \args -> opTranslate args (mo_wordURem dflags)
+ IntAddOp -> \args -> opTranslate args (mo_wordAdd platform)
+ IntSubOp -> \args -> opTranslate args (mo_wordSub platform)
+ WordAddOp -> \args -> opTranslate args (mo_wordAdd platform)
+ WordSubOp -> \args -> opTranslate args (mo_wordSub platform)
+ AddrAddOp -> \args -> opTranslate args (mo_wordAdd platform)
+ AddrSubOp -> \args -> opTranslate args (mo_wordSub platform)
+
+ IntEqOp -> \args -> opTranslate args (mo_wordEq platform)
+ IntNeOp -> \args -> opTranslate args (mo_wordNe platform)
+ WordEqOp -> \args -> opTranslate args (mo_wordEq platform)
+ WordNeOp -> \args -> opTranslate args (mo_wordNe platform)
+ AddrEqOp -> \args -> opTranslate args (mo_wordEq platform)
+ AddrNeOp -> \args -> opTranslate args (mo_wordNe platform)
+
+ AndOp -> \args -> opTranslate args (mo_wordAnd platform)
+ OrOp -> \args -> opTranslate args (mo_wordOr platform)
+ XorOp -> \args -> opTranslate args (mo_wordXor platform)
+ NotOp -> \args -> opTranslate args (mo_wordNot platform)
+ SllOp -> \args -> opTranslate args (mo_wordShl platform)
+ SrlOp -> \args -> opTranslate args (mo_wordUShr platform)
+
+ AddrRemOp -> \args -> opTranslate args (mo_wordURem platform)
-- Native word signed ops
- IntMulOp -> \args -> opTranslate args (mo_wordMul dflags)
- IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags))
- IntQuotOp -> \args -> opTranslate args (mo_wordSQuot dflags)
- IntRemOp -> \args -> opTranslate args (mo_wordSRem dflags)
- IntNegOp -> \args -> opTranslate args (mo_wordSNeg dflags)
-
- IntGeOp -> \args -> opTranslate args (mo_wordSGe dflags)
- IntLeOp -> \args -> opTranslate args (mo_wordSLe dflags)
- IntGtOp -> \args -> opTranslate args (mo_wordSGt dflags)
- IntLtOp -> \args -> opTranslate args (mo_wordSLt dflags)
-
- AndIOp -> \args -> opTranslate args (mo_wordAnd dflags)
- OrIOp -> \args -> opTranslate args (mo_wordOr dflags)
- XorIOp -> \args -> opTranslate args (mo_wordXor dflags)
- NotIOp -> \args -> opTranslate args (mo_wordNot dflags)
- ISllOp -> \args -> opTranslate args (mo_wordShl dflags)
- ISraOp -> \args -> opTranslate args (mo_wordSShr dflags)
- ISrlOp -> \args -> opTranslate args (mo_wordUShr dflags)
+ IntMulOp -> \args -> opTranslate args (mo_wordMul platform)
+ IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))
+ IntQuotOp -> \args -> opTranslate args (mo_wordSQuot platform)
+ IntRemOp -> \args -> opTranslate args (mo_wordSRem platform)
+ IntNegOp -> \args -> opTranslate args (mo_wordSNeg platform)
+
+ IntGeOp -> \args -> opTranslate args (mo_wordSGe platform)
+ IntLeOp -> \args -> opTranslate args (mo_wordSLe platform)
+ IntGtOp -> \args -> opTranslate args (mo_wordSGt platform)
+ IntLtOp -> \args -> opTranslate args (mo_wordSLt platform)
+
+ AndIOp -> \args -> opTranslate args (mo_wordAnd platform)
+ OrIOp -> \args -> opTranslate args (mo_wordOr platform)
+ XorIOp -> \args -> opTranslate args (mo_wordXor platform)
+ NotIOp -> \args -> opTranslate args (mo_wordNot platform)
+ ISllOp -> \args -> opTranslate args (mo_wordShl platform)
+ ISraOp -> \args -> opTranslate args (mo_wordSShr platform)
+ ISrlOp -> \args -> opTranslate args (mo_wordUShr platform)
-- Native word unsigned ops
- WordGeOp -> \args -> opTranslate args (mo_wordUGe dflags)
- WordLeOp -> \args -> opTranslate args (mo_wordULe dflags)
- WordGtOp -> \args -> opTranslate args (mo_wordUGt dflags)
- WordLtOp -> \args -> opTranslate args (mo_wordULt dflags)
+ WordGeOp -> \args -> opTranslate args (mo_wordUGe platform)
+ WordLeOp -> \args -> opTranslate args (mo_wordULe platform)
+ WordGtOp -> \args -> opTranslate args (mo_wordUGt platform)
+ WordLtOp -> \args -> opTranslate args (mo_wordULt platform)
- WordMulOp -> \args -> opTranslate args (mo_wordMul dflags)
- WordQuotOp -> \args -> opTranslate args (mo_wordUQuot dflags)
- WordRemOp -> \args -> opTranslate args (mo_wordURem dflags)
+ WordMulOp -> \args -> opTranslate args (mo_wordMul platform)
+ WordQuotOp -> \args -> opTranslate args (mo_wordUQuot platform)
+ WordRemOp -> \args -> opTranslate args (mo_wordURem platform)
- AddrGeOp -> \args -> opTranslate args (mo_wordUGe dflags)
- AddrLeOp -> \args -> opTranslate args (mo_wordULe dflags)
- AddrGtOp -> \args -> opTranslate args (mo_wordUGt dflags)
- AddrLtOp -> \args -> opTranslate args (mo_wordULt dflags)
+ AddrGeOp -> \args -> opTranslate args (mo_wordUGe platform)
+ AddrLeOp -> \args -> opTranslate args (mo_wordULe platform)
+ AddrGtOp -> \args -> opTranslate args (mo_wordUGt platform)
+ AddrLtOp -> \args -> opTranslate args (mo_wordULt platform)
-- Int8# signed ops
- Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags))
- Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8)
+ Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))
+ Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)
Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8)
Int8AddOp -> \args -> opTranslate args (MO_Add W8)
Int8SubOp -> \args -> opTranslate args (MO_Sub W8)
@@ -1195,8 +1195,8 @@ emitPrimOp dflags = \case
-- Word8# unsigned ops
- Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags))
- Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8)
+ Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))
+ Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)
Word8NotOp -> \args -> opTranslate args (MO_Not W8)
Word8AddOp -> \args -> opTranslate args (MO_Add W8)
Word8SubOp -> \args -> opTranslate args (MO_Sub W8)
@@ -1213,8 +1213,8 @@ emitPrimOp dflags = \case
-- Int16# signed ops
- Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags))
- Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16)
+ Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))
+ Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)
Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16)
Int16AddOp -> \args -> opTranslate args (MO_Add W16)
Int16SubOp -> \args -> opTranslate args (MO_Sub W16)
@@ -1231,8 +1231,8 @@ emitPrimOp dflags = \case
-- Word16# unsigned ops
- Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags))
- Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16)
+ Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))
+ Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)
Word16NotOp -> \args -> opTranslate args (MO_Not W16)
Word16AddOp -> \args -> opTranslate args (MO_Add W16)
Word16SubOp -> \args -> opTranslate args (MO_Sub W16)
@@ -1249,12 +1249,12 @@ emitPrimOp dflags = \case
-- Char# ops
- CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth dflags))
- CharNeOp -> \args -> opTranslate args (MO_Ne (wordWidth dflags))
- CharGeOp -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags))
- CharLeOp -> \args -> opTranslate args (MO_U_Le (wordWidth dflags))
- CharGtOp -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags))
- CharLtOp -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags))
+ CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform))
+ CharNeOp -> \args -> opTranslate args (MO_Ne (wordWidth platform))
+ CharGeOp -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))
+ CharLeOp -> \args -> opTranslate args (MO_U_Le (wordWidth platform))
+ CharGtOp -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))
+ CharLtOp -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))
-- Double ops
@@ -1314,32 +1314,32 @@ emitPrimOp dflags = \case
-- Conversions
- Int2DoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64)
- Double2IntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags))
+ Int2DoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)
+ Double2IntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))
- Int2FloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32)
- Float2IntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags))
+ Int2FloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)
+ Float2IntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))
Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)
Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)
-- Word comparisons masquerading as more exotic things.
- SameMutVarOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameMVarOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)
- SameTVarOp -> \args -> opTranslate args (mo_wordEq dflags)
- EqStablePtrOp -> \args -> opTranslate args (mo_wordEq dflags)
+ SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameMVarOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)
+ SameTVarOp -> \args -> opTranslate args (mo_wordEq platform)
+ EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)
-- See Note [Comparing stable names]
- EqStableNameOp -> \args -> opTranslate args (mo_wordEq dflags)
+ EqStableNameOp -> \args -> opTranslate args (mo_wordEq platform)
IntQuotRemOp -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
- then Left (MO_S_QuotRem (wordWidth dflags))
- else Right (genericIntQuotRemOp (wordWidth dflags))
+ then Left (MO_S_QuotRem (wordWidth platform))
+ else Right (genericIntQuotRemOp (wordWidth platform))
Int8QuotRemOp -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
@@ -1353,13 +1353,13 @@ emitPrimOp dflags = \case
WordQuotRemOp -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
- then Left (MO_U_QuotRem (wordWidth dflags))
- else Right (genericWordQuotRemOp (wordWidth dflags))
+ then Left (MO_U_QuotRem (wordWidth platform))
+ else Right (genericWordQuotRemOp (wordWidth platform))
WordQuotRem2Op -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_U_QuotRem2 (wordWidth dflags))
- else Right (genericWordQuotRem2Op dflags)
+ then Left (MO_U_QuotRem2 (wordWidth platform))
+ else Right (genericWordQuotRem2Op platform)
Word8QuotRemOp -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)
@@ -1373,37 +1373,37 @@ emitPrimOp dflags = \case
WordAdd2Op -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_Add2 (wordWidth dflags))
+ then Left (MO_Add2 (wordWidth platform))
else Right genericWordAdd2Op
WordAddCOp -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_AddWordC (wordWidth dflags))
+ then Left (MO_AddWordC (wordWidth platform))
else Right genericWordAddCOp
WordSubCOp -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_SubWordC (wordWidth dflags))
+ then Left (MO_SubWordC (wordWidth platform))
else Right genericWordSubCOp
IntAddCOp -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_AddIntC (wordWidth dflags))
+ then Left (MO_AddIntC (wordWidth platform))
else Right genericIntAddCOp
IntSubCOp -> \args -> opCallishHandledLater args $
if (ncg && (x86ish || ppc)) || llvm
- then Left (MO_SubIntC (wordWidth dflags))
+ then Left (MO_SubIntC (wordWidth platform))
else Right genericIntSubCOp
WordMul2Op -> \args -> opCallishHandledLater args $
if ncg && (x86ish || ppc) || llvm
- then Left (MO_U_Mul2 (wordWidth dflags))
+ then Left (MO_U_Mul2 (wordWidth platform))
else Right genericWordMul2Op
IntMul2Op -> \args -> opCallishHandledLater args $
if ncg && x86ish
- then Left (MO_S_Mul2 (wordWidth dflags))
+ then Left (MO_S_Mul2 (wordWidth platform))
else Right genericIntMul2Op
FloatFabsOp -> \args -> opCallishHandledLater args $
@@ -1426,8 +1426,8 @@ emitPrimOp dflags = \case
-- That won't work.
let tycon = tyConAppTyCon res_ty
MASSERT(isEnumerationTyCon tycon)
- dflags <- getDynFlags
- pure [tagToClosure dflags tycon amode]
+ platform <- getPlatform
+ pure [tagToClosure platform tycon amode]
-- Out of line primops.
-- TODO compiler need not know about these
@@ -1523,6 +1523,7 @@ emitPrimOp dflags = \case
SetThreadAllocationCounter -> alwaysExternal
where
+ platform = targetPlatform dflags
alwaysExternal = \_ -> PrimopCmmEmit_External
-- Note [QuotRem optimization]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1549,11 +1550,11 @@ emitPrimOp dflags = \case
llvm = case hscTarget dflags of
HscLlvm -> True
_ -> False
- x86ish = case platformArch (targetPlatform dflags) of
+ x86ish = case platformArch platform of
ArchX86 -> True
ArchX86_64 -> True
_ -> False
- ppc = case platformArch (targetPlatform dflags) of
+ ppc = case platformArch platform of
ArchPPC -> True
ArchPPC_64 _ -> True
_ -> False
@@ -1573,12 +1574,12 @@ opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg
where [arg] = args
opNarrow
- :: DynFlags
+ :: Platform
-> [CmmExpr]
-> (Width -> Width -> MachOp, Width)
-> PrimopCmmEmit
-opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $
- CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
+opNarrow platform args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $
+ CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]
where [arg] = args
-- | These primops are implemented by CallishMachOps, because they sometimes
@@ -1626,21 +1627,21 @@ genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
(CmmMachOp (MO_U_Rem width) [arg_x, arg_y])
genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
-genericWordQuotRem2Op :: DynFlags -> GenericOp
-genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
- = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
- where ty = cmmExprType dflags arg_x_high
- shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i]
- shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
- or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
- ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y]
- ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y]
- minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y]
- times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
+genericWordQuotRem2Op :: Platform -> GenericOp
+genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
+ = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low
+ where ty = cmmExprType platform arg_x_high
+ shl x i = CmmMachOp (MO_Shl (wordWidth platform)) [x, i]
+ shr x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]
+ or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
+ ge x y = CmmMachOp (MO_U_Ge (wordWidth platform)) [x, y]
+ ne x y = CmmMachOp (MO_Ne (wordWidth platform)) [x, y]
+ minus x y = CmmMachOp (MO_Sub (wordWidth platform)) [x, y]
+ times x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]
zero = lit 0
one = lit 1
- negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
- lit i = CmmLit (CmmInt i (wordWidth dflags))
+ negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)
+ lit i = CmmLit (CmmInt i (wordWidth platform))
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
@@ -1677,17 +1678,17 @@ genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
genericWordAdd2Op :: GenericOp
genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
- = do dflags <- getDynFlags
- r1 <- newTemp (cmmExprType dflags arg_x)
- r2 <- newTemp (cmmExprType dflags arg_x)
- let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
- bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
- add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
- or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
- hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- (wordWidth dflags))
- hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+ = do platform <- getPlatform
+ r1 <- newTemp (cmmExprType platform arg_x)
+ r2 <- newTemp (cmmExprType platform arg_x)
+ let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
+ hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))
+ (wordWidth platform))
+ hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))
emit $ catAGraphs
[mkAssign (CmmLocal r1)
(add (bottomHalf arg_x) (bottomHalf arg_y)),
@@ -1711,19 +1712,19 @@ genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
genericWordAddCOp :: GenericOp
genericWordAddCOp [res_r, res_c] [aa, bb]
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp (mo_wordUShr dflags) [
- CmmMachOp (mo_wordOr dflags) [
- CmmMachOp (mo_wordAnd dflags) [aa,bb],
- CmmMachOp (mo_wordAnd dflags) [
- CmmMachOp (mo_wordOr dflags) [aa,bb],
- CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr platform) [
+ CmmMachOp (mo_wordOr platform) [
+ CmmMachOp (mo_wordAnd platform) [aa,bb],
+ CmmMachOp (mo_wordAnd platform) [
+ CmmMachOp (mo_wordOr platform) [aa,bb],
+ CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]
]
],
- mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+ mkIntExpr platform (platformWordSizeInBits platform - 1)
]
]
genericWordAddCOp _ _ = panic "genericWordAddCOp"
@@ -1738,25 +1739,25 @@ genericWordAddCOp _ _ = panic "genericWordAddCOp"
-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
genericWordSubCOp :: GenericOp
genericWordSubCOp [res_r, res_c] [aa, bb]
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp (mo_wordUShr dflags) [
- CmmMachOp (mo_wordOr dflags) [
- CmmMachOp (mo_wordAnd dflags) [
- CmmMachOp (mo_wordNot dflags) [aa],
+ CmmMachOp (mo_wordUShr platform) [
+ CmmMachOp (mo_wordOr platform) [
+ CmmMachOp (mo_wordAnd platform) [
+ CmmMachOp (mo_wordNot platform) [aa],
bb
],
- CmmMachOp (mo_wordAnd dflags) [
- CmmMachOp (mo_wordOr dflags) [
- CmmMachOp (mo_wordNot dflags) [aa],
+ CmmMachOp (mo_wordAnd platform) [
+ CmmMachOp (mo_wordOr platform) [
+ CmmMachOp (mo_wordNot platform) [aa],
bb
],
CmmReg (CmmLocal res_r)
]
],
- mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+ mkIntExpr platform (platformWordSizeInBits platform - 1)
]
]
genericWordSubCOp _ _ = panic "genericWordSubCOp"
@@ -1783,16 +1784,16 @@ genericIntAddCOp [res_r, res_c] [aa, bb]
c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
-}
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp (mo_wordUShr dflags) [
- CmmMachOp (mo_wordAnd dflags) [
- CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
- CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr platform) [
+ CmmMachOp (mo_wordAnd platform) [
+ CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],
+ CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+ mkIntExpr platform (platformWordSizeInBits platform - 1)
]
]
genericIntAddCOp _ _ = panic "genericIntAddCOp"
@@ -1808,40 +1809,40 @@ genericIntSubCOp [res_r, res_c] [aa, bb]
c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
-}
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp (mo_wordUShr dflags) [
- CmmMachOp (mo_wordAnd dflags) [
- CmmMachOp (mo_wordXor dflags) [aa,bb],
- CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr platform) [
+ CmmMachOp (mo_wordAnd platform) [
+ CmmMachOp (mo_wordXor platform) [aa,bb],
+ CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+ mkIntExpr platform (platformWordSizeInBits platform - 1)
]
]
genericIntSubCOp _ _ = panic "genericIntSubCOp"
genericWordMul2Op :: GenericOp
genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
- = do dflags <- getDynFlags
- let t = cmmExprType dflags arg_x
+ = do platform <- getPlatform
+ let t = cmmExprType platform arg_x
xlyl <- liftM CmmLocal $ newTemp t
xlyh <- liftM CmmLocal $ newTemp t
xhyl <- liftM CmmLocal $ newTemp t
r <- liftM CmmLocal $ newTemp t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
- let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
- bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
- add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+ let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]
sum = foldl1 add
- mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
- or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
- hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- (wordWidth dflags))
- hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+ mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
+ hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))
+ (wordWidth platform))
+ hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))
emit $ catAGraphs
[mkAssign xlyl
(mul (bottomHalf arg_x) (bottomHalf arg_y)),
@@ -1866,8 +1867,9 @@ genericWordMul2Op _ _ = panic "genericWordMul2Op"
genericIntMul2Op :: GenericOp
genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]
= do dflags <- getDynFlags
+ platform <- getPlatform
-- Implement algorithm from Hacker's Delight, 2nd edition, p.174
- let t = cmmExprType dflags arg_x
+ let t = cmmExprType platform arg_x
p <- newTemp t
-- 1) compute the multiplication as if numbers were unsigned
let wordMul2 = case emitPrimOp dflags WordMul2Op [arg_x,arg_y] of
@@ -1883,7 +1885,7 @@ genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]
f x y = (carryFill x) `and` y
wwm1 = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)
rl x = CmmReg (CmmLocal x)
- ww = wordWidth dflags
+ ww = wordWidth platform
emit $ catAGraphs
[ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)
, mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))
@@ -1897,7 +1899,7 @@ genericIntMul2Op _ _ = panic "genericIntMul2Op"
-- | otherwise = negateFloat x
genericFabsOp :: Width -> GenericOp
genericFabsOp w [res_r] [aa]
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
let zero = CmmLit (CmmFloat 0 w)
eq x y = CmmMachOp (MO_F_Eq w) [x, y]
@@ -1908,7 +1910,7 @@ genericFabsOp w [res_r] [aa]
g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]
g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]
- res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)
+ res_t <- CmmLocal <$> newTemp (cmmExprType platform aa)
let g3 = catAGraphs [mkAssign res_t aa,
mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]
@@ -1982,7 +1984,8 @@ doReadPtrArrayOp :: LocalReg
-> FCode ()
doReadPtrArrayOp res addr idx
= do dflags <- getDynFlags
- mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx
+ platform <- getPlatform
+ mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx
doWriteOffAddrOp :: Maybe MachOp
-> CmmType
@@ -2011,11 +2014,12 @@ doWritePtrArrayOp :: CmmExpr
-> FCode ()
doWritePtrArrayOp addr idx val
= do dflags <- getDynFlags
- let ty = cmmExprType dflags val
+ platform <- getPlatform
+ let ty = cmmExprType platform val
hdr_size = arrPtrsHdrSize dflags
-- Update remembered set for non-moving collector
- whenUpdRemSetEnabled dflags
- $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)
+ whenUpdRemSetEnabled
+ $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)
-- This write barrier is to ensure that the heap writes to the object
-- referred to by val have happened before we write val into the array.
-- See #12469 for details.
@@ -2025,16 +2029,17 @@ doWritePtrArrayOp addr idx val
-- the write barrier. We must write a byte into the mark table:
-- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
emit $ mkStore (
- cmmOffsetExpr dflags
- (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)
+ cmmOffsetExpr platform
+ (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)
(loadArrPtrsSize dflags addr))
- (CmmMachOp (mo_wordUShr dflags) [idx,
- mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
+ (CmmMachOp (mo_wordUShr platform) [idx,
+ mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)])
) (CmmLit (CmmInt 1 W8))
loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)
where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags
+ platform = targetPlatform dflags
mkBasicIndexedRead :: ByteOff -- Initial offset in bytes
-> Maybe MachOp -- Optional result cast
@@ -2045,12 +2050,12 @@ mkBasicIndexedRead :: ByteOff -- Initial offset in bytes
-> CmmExpr -- Index
-> FCode ()
mkBasicIndexedRead off Nothing ty res base idx_ty idx
- = do dflags <- getDynFlags
- emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)
+ = do platform <- getPlatform
+ emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)
mkBasicIndexedRead off (Just cast) ty res base idx_ty idx
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
emitAssign (CmmLocal res) (CmmMachOp cast [
- cmmLoadIndexOffExpr dflags off ty base idx_ty idx])
+ cmmLoadIndexOffExpr platform off ty base idx_ty idx])
mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes
-> Maybe MachOp -- Optional value cast
@@ -2060,32 +2065,32 @@ mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes
-> CmmExpr -- Value to write
-> FCode ()
mkBasicIndexedWrite off Nothing base idx_ty idx val
- = do dflags <- getDynFlags
- emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val
+ = do platform <- getPlatform
+ emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val
mkBasicIndexedWrite off (Just cast) base idx_ty idx val
= mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
-- ----------------------------------------------------------------------------
-- Misc utils
-cmmIndexOffExpr :: DynFlags
+cmmIndexOffExpr :: Platform
-> ByteOff -- Initial offset in bytes
-> Width -- Width of element by which we are indexing
-> CmmExpr -- Base address
-> CmmExpr -- Index
-> CmmExpr
-cmmIndexOffExpr dflags off width base idx
- = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx
+cmmIndexOffExpr platform off width base idx
+ = cmmIndexExpr platform width (cmmOffsetB platform base off) idx
-cmmLoadIndexOffExpr :: DynFlags
+cmmLoadIndexOffExpr :: Platform
-> ByteOff -- Initial offset in bytes
-> CmmType -- Type of element we are accessing
-> CmmExpr -- Base address
-> CmmType -- Type of element by which we are indexing
-> CmmExpr -- Index
-> CmmExpr
-cmmLoadIndexOffExpr dflags off ty base idx_ty idx
- = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty
+cmmLoadIndexOffExpr platform off ty base idx_ty idx
+ = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty
setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
@@ -2101,29 +2106,29 @@ vecCmmCat IntVec = cmmBits
vecCmmCat WordVec = cmmBits
vecCmmCat FloatVec = cmmFloat
-vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
-vecElemInjectCast _ FloatVec _ = Nothing
-vecElemInjectCast dflags IntVec W8 = Just (mo_WordTo8 dflags)
-vecElemInjectCast dflags IntVec W16 = Just (mo_WordTo16 dflags)
-vecElemInjectCast dflags IntVec W32 = Just (mo_WordTo32 dflags)
-vecElemInjectCast _ IntVec W64 = Nothing
-vecElemInjectCast dflags WordVec W8 = Just (mo_WordTo8 dflags)
-vecElemInjectCast dflags WordVec W16 = Just (mo_WordTo16 dflags)
-vecElemInjectCast dflags WordVec W32 = Just (mo_WordTo32 dflags)
-vecElemInjectCast _ WordVec W64 = Nothing
-vecElemInjectCast _ _ _ = Nothing
-
-vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
-vecElemProjectCast _ FloatVec _ = Nothing
-vecElemProjectCast dflags IntVec W8 = Just (mo_s_8ToWord dflags)
-vecElemProjectCast dflags IntVec W16 = Just (mo_s_16ToWord dflags)
-vecElemProjectCast dflags IntVec W32 = Just (mo_s_32ToWord dflags)
-vecElemProjectCast _ IntVec W64 = Nothing
-vecElemProjectCast dflags WordVec W8 = Just (mo_u_8ToWord dflags)
-vecElemProjectCast dflags WordVec W16 = Just (mo_u_16ToWord dflags)
-vecElemProjectCast dflags WordVec W32 = Just (mo_u_32ToWord dflags)
-vecElemProjectCast _ WordVec W64 = Nothing
-vecElemProjectCast _ _ _ = Nothing
+vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemInjectCast _ FloatVec _ = Nothing
+vecElemInjectCast platform IntVec W8 = Just (mo_WordTo8 platform)
+vecElemInjectCast platform IntVec W16 = Just (mo_WordTo16 platform)
+vecElemInjectCast platform IntVec W32 = Just (mo_WordTo32 platform)
+vecElemInjectCast _ IntVec W64 = Nothing
+vecElemInjectCast platform WordVec W8 = Just (mo_WordTo8 platform)
+vecElemInjectCast platform WordVec W16 = Just (mo_WordTo16 platform)
+vecElemInjectCast platform WordVec W32 = Just (mo_WordTo32 platform)
+vecElemInjectCast _ WordVec W64 = Nothing
+vecElemInjectCast _ _ _ = Nothing
+
+vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemProjectCast _ FloatVec _ = Nothing
+vecElemProjectCast platform IntVec W8 = Just (mo_s_8ToWord platform)
+vecElemProjectCast platform IntVec W16 = Just (mo_s_16ToWord platform)
+vecElemProjectCast platform IntVec W32 = Just (mo_s_32ToWord platform)
+vecElemProjectCast _ IntVec W64 = Nothing
+vecElemProjectCast platform WordVec W8 = Just (mo_u_8ToWord platform)
+vecElemProjectCast platform WordVec W16 = Just (mo_u_16ToWord platform)
+vecElemProjectCast platform WordVec W32 = Just (mo_u_32ToWord platform)
+vecElemProjectCast _ WordVec W64 = Nothing
+vecElemProjectCast _ _ _ = Nothing
-- NOTE [SIMD Design for the future]
@@ -2267,10 +2272,10 @@ doVecInsertOp :: Maybe MachOp -- Cast from element to vector component
-> CmmFormal -- Destination for result
-> FCode ()
doVecInsertOp maybe_pre_write_cast ty src e idx res = do
- dflags <- getDynFlags
+ platform <- getPlatform
-- vector indices are always 32-bits
let idx' :: CmmExpr
- idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]
+ idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]
if isFloatType (vecElemType ty)
then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])
else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])
@@ -2324,8 +2329,8 @@ doPrefetchValueOp :: Int
-> [CmmExpr]
-> FCode ()
doPrefetchValueOp locality [addr]
- = do dflags <- getDynFlags
- mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth dflags)))
+ = do platform <- getPlatform
+ mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth platform)))
doPrefetchValueOp _ _
= panic "GHC.StgToCmm.Prim: doPrefetchValueOp"
@@ -2336,8 +2341,8 @@ mkBasicPrefetch :: Int -- Locality level 0-3
-> CmmExpr -- Index
-> FCode ()
mkBasicPrefetch locality off base idx
- = do dflags <- getDynFlags
- emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]
+ = do platform <- getPlatform
+ emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx]
return ()
-- ----------------------------------------------------------------------------
@@ -2349,18 +2354,19 @@ mkBasicPrefetch locality off base idx
doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()
doNewByteArrayOp res_r n = do
dflags <- getDynFlags
+ platform <- getPlatform
let info_ptr = mkLblExpr mkArrWords_infoLabel
- rep = arrWordsRep dflags n
+ rep = arrWordsRep platform n
- tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))
- (mkIntExpr dflags (nonHdrSize dflags rep))
- (zeroExpr dflags)
+ tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags))
+ (mkIntExpr platform (nonHdrSize platform rep))
+ (zeroExpr platform)
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr cccsExpr
- [ (mkIntExpr dflags n,
+ [ (mkIntExpr platform n,
hdr_size + oFFSET_StgArrBytes_bytes dflags)
]
@@ -2373,8 +2379,9 @@ doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr ->
-> FCode ()
doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
dflags <- getDynFlags
- ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off
- ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off
+ platform <- getPlatform
+ ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off
+ ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off
-- short-cut in case of equal pointers avoiding a costly
-- subroutine call to the memcmp(3) routine; the Cmm logic below
@@ -2411,8 +2418,8 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
l_ptr_eq <- newBlockId
l_ptr_ne <- newBlockId
- emit (mkAssign (CmmLocal res) (zeroExpr dflags))
- emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)
+ emit (mkAssign (CmmLocal res) (zeroExpr platform))
+ emit (mkCbranch (cmmEqWord platform ba1_p ba2_p)
l_ptr_eq l_ptr_ne (Just False))
emitLabel l_ptr_ne
@@ -2449,11 +2456,11 @@ doCopyMutableByteArrayOp = emitCopyByteArray 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 align = do
- dflags <- getDynFlags
+ platform <- getPlatform
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p bytes align)
(getCode $ emitMemcpyCall dst_p src_p bytes align)
- emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+ emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> Alignment -> FCode ())
@@ -2461,12 +2468,13 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCopyByteArray copy src src_off dst dst_off n = do
dflags <- getDynFlags
+ platform <- getPlatform
let byteArrayAlignment = wordAlignment dflags
srcOffAlignment = cmmExprAlignment src_off
dstOffAlignment = cmmExprAlignment dst_off
align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]
- dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
- src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+ dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off
+ src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off
copy src dst dst_p src_p n align
-- | Takes a source 'ByteArray#', an offset in the source array, a
@@ -2476,7 +2484,8 @@ doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
doCopyByteArrayToAddrOp src src_off dst_p bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
- src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+ platform <- getPlatform
+ src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off
emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-- | Takes a source 'MutableByteArray#', an offset in the source array, a
@@ -2493,7 +2502,8 @@ doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
- dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
+ platform <- getPlatform
+ dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off
emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
@@ -2507,12 +2517,13 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
doSetByteArrayOp ba off len c = do
dflags <- getDynFlags
+ platform <- getPlatform
let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap
offsetAlignment = cmmExprAlignment off
align = min byteArrayAlignment offsetAlignment
- p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
+ p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off
emitMemsetCall p c len align
-- ----------------------------------------------------------------------------
@@ -2528,20 +2539,21 @@ doNewArrayOp :: CmmFormal -- ^ return register
-> FCode ()
doNewArrayOp res_r rep info payload n init = do
dflags <- getDynFlags
+ platform <- getPlatform
let info_ptr = mkLblExpr info
- tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))
- (mkIntExpr dflags (nonHdrSize dflags rep))
- (zeroExpr dflags)
+ tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep))
+ (mkIntExpr platform (nonHdrSize platform rep))
+ (zeroExpr platform)
base <- allocHeapClosure rep info_ptr cccsExpr payload
- arr <- CmmLocal `fmap` newTemp (bWord dflags)
+ arr <- CmmLocal `fmap` newTemp (bWord platform)
emit $ mkAssign arr base
-- Initialise all elements of the array
- let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)
+ let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off)
initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
emit (catAGraphs initialization)
@@ -2576,7 +2588,8 @@ doCopyArrayOp = emitCopyArray copy
-- they're of different types)
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
- emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+ platform <- getPlatform
+ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags)
@@ -2593,12 +2606,13 @@ doCopyMutableArrayOp = emitCopyArray copy
-- 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 dflags bytes)
+ (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags))
- (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+ (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags))
- emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+ emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
-> FCode ()) -- ^ copy function
@@ -2611,6 +2625,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
emitCopyArray copy src0 src_off dst0 dst_off0 n =
when (n /= 0) $ do
dflags <- getDynFlags
+ platform <- getPlatform
-- Passed as arguments (be careful)
src <- assignTempE src0
@@ -2618,22 +2633,22 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
dst_off <- assignTempE dst_off0
-- Nonmoving collector write barrier
- emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n
+ emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
- dst_elems_p <- assignTempE $ cmmOffsetB dflags dst
+ dst_elems_p <- assignTempE $ cmmOffsetB platform dst
(arrPtrsHdrSize dflags)
- dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
- src_p <- assignTempE $ cmmOffsetExprW dflags
- (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
- let bytes = wordsToBytes dflags n
+ dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off
+ src_p <- assignTempE $ cmmOffsetExprW platform
+ (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off
+ let bytes = wordsToBytes platform n
copy src dst dst_p src_p bytes
-- The base address of the destination card table
- dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p
+ dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p
(loadArrPtrsSize dflags dst)
emitSetCards dst_off dst_cards_p n
@@ -2646,7 +2661,8 @@ doCopySmallArrayOp = emitCopySmallArray copy
-- they're of different types)
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
- emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+ platform <- getPlatform
+ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags)
@@ -2659,12 +2675,13 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
-- 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 dflags bytes)
+ (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags))
- (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+ (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
(wordAlignment dflags))
- emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+ emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
-> FCode ()) -- ^ copy function
@@ -2677,22 +2694,23 @@ emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
emitCopySmallArray copy src0 src_off dst0 dst_off n =
when (n /= 0) $ do
dflags <- getDynFlags
+ platform <- getPlatform
-- Passed as arguments (be careful)
src <- assignTempE src0
dst <- assignTempE dst0
-- Nonmoving collector write barrier
- emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n
+ emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
- dst_p <- assignTempE $ cmmOffsetExprW dflags
- (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off
- src_p <- assignTempE $ cmmOffsetExprW dflags
- (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off
- let bytes = wordsToBytes dflags n
+ dst_p <- assignTempE $ cmmOffsetExprW platform
+ (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off
+ src_p <- assignTempE $ cmmOffsetExprW platform
+ (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off
+ let bytes = wordsToBytes platform n
copy src dst dst_p src_p bytes
@@ -2704,33 +2722,34 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
-> FCode ()
emitCloneArray info_p res_r src src_off n = do
dflags <- getDynFlags
+ platform <- getPlatform
let info_ptr = mkLblExpr info_p
rep = arrPtrsRep dflags n
- tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))
- (mkIntExpr dflags (nonHdrSize dflags rep))
- (zeroExpr dflags)
+ tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags))
+ (mkIntExpr platform (nonHdrSize platform rep))
+ (zeroExpr platform)
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr cccsExpr
- [ (mkIntExpr dflags n,
+ [ (mkIntExpr platform n,
hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
- , (mkIntExpr dflags (nonHdrSizeW rep),
+ , (mkIntExpr platform (nonHdrSizeW rep),
hdr_size + oFFSET_StgMutArrPtrs_size dflags)
]
- arr <- CmmLocal `fmap` newTemp (bWord dflags)
+ arr <- CmmLocal `fmap` newTemp (bWord platform)
emit $ mkAssign arr base
- dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+ dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)
(arrPtrsHdrSize dflags)
- src_p <- assignTempE $ cmmOffsetExprW dflags src
- (cmmAddWord dflags
- (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)
+ src_p <- assignTempE $ cmmOffsetExprW platform src
+ (cmmAddWord platform
+ (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off)
- emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+ emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
(wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
@@ -2743,31 +2762,32 @@ emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
-> FCode ()
emitCloneSmallArray info_p res_r src src_off n = do
dflags <- getDynFlags
+ platform <- getPlatform
let info_ptr = mkLblExpr info_p
rep = smallArrPtrsRep n
- tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))
- (mkIntExpr dflags (nonHdrSize dflags rep))
- (zeroExpr dflags)
+ tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags))
+ (mkIntExpr platform (nonHdrSize platform rep))
+ (zeroExpr platform)
let hdr_size = fixedHdrSize dflags
base <- allocHeapClosure rep info_ptr cccsExpr
- [ (mkIntExpr dflags n,
+ [ (mkIntExpr platform n,
hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
]
- arr <- CmmLocal `fmap` newTemp (bWord dflags)
+ arr <- CmmLocal `fmap` newTemp (bWord platform)
emit $ mkAssign arr base
- dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+ dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)
(smallArrPtrsHdrSize dflags)
- src_p <- assignTempE $ cmmOffsetExprW dflags src
- (cmmAddWord dflags
- (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
+ src_p <- assignTempE $ cmmOffsetExprW platform src
+ (cmmAddWord platform
+ (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off)
- emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+ emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
(wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
@@ -2779,20 +2799,22 @@ emitCloneSmallArray info_p res_r src src_off n = do
emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()
emitSetCards dst_start dst_cards_start n = do
dflags <- getDynFlags
+ platform <- getPlatform
start_card <- assignTempE $ cardCmm dflags dst_start
let end_card = cardCmm dflags
- (cmmSubWord dflags
- (cmmAddWord dflags dst_start (mkIntExpr dflags n))
- (mkIntExpr dflags 1))
- emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
- (mkIntExpr dflags 1)
- (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
+ (cmmSubWord platform
+ (cmmAddWord platform dst_start (mkIntExpr platform n))
+ (mkIntExpr platform 1))
+ emitMemsetCall (cmmAddWord platform dst_cards_start start_card)
+ (mkIntExpr platform 1)
+ (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1))
(mkAlignment 1) -- no alignment (1 byte)
-- Convert an element index to a card index
cardCmm :: DynFlags -> CmmExpr -> CmmExpr
cardCmm dflags i =
- cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))
+ cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags))
+ where platform = targetPlatform dflags
------------------------------------------------------------------------------
-- SmallArray PrimOp implementations
@@ -2803,8 +2825,9 @@ doReadSmallPtrArrayOp :: LocalReg
-> FCode ()
doReadSmallPtrArrayOp res addr idx = do
dflags <- getDynFlags
- mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr
- (gcWord dflags) idx
+ platform <- getPlatform
+ mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr
+ (gcWord platform) idx
doWriteSmallPtrArrayOp :: CmmExpr
-> CmmExpr
@@ -2812,12 +2835,13 @@ doWriteSmallPtrArrayOp :: CmmExpr
-> FCode ()
doWriteSmallPtrArrayOp addr idx val = do
dflags <- getDynFlags
- let ty = cmmExprType dflags val
+ platform <- getPlatform
+ let ty = cmmExprType platform val
-- Update remembered set for non-moving collector
tmp <- newTemp ty
mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx
- whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
+ whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
emitPrimCall [] MO_WriteBarrier [] -- #12469
mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
@@ -2838,8 +2862,9 @@ doAtomicRMW :: LocalReg -- ^ Result reg
-> FCode ()
doAtomicRMW res amop mba idx idx_ty n = do
dflags <- getDynFlags
+ platform <- getPlatform
let width = typeWidth idx_ty
- addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+ addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)
width mba idx
emitPrimCall
[ res ]
@@ -2855,8 +2880,9 @@ doAtomicReadByteArray
-> FCode ()
doAtomicReadByteArray res mba idx idx_ty = do
dflags <- getDynFlags
+ platform <- getPlatform
let width = typeWidth idx_ty
- addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+ addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)
width mba idx
emitPrimCall
[ res ]
@@ -2872,8 +2898,9 @@ doAtomicWriteByteArray
-> FCode ()
doAtomicWriteByteArray mba idx idx_ty val = do
dflags <- getDynFlags
+ platform <- getPlatform
let width = typeWidth idx_ty
- addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+ addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)
width mba idx
emitPrimCall
[ {- no results -} ]
@@ -2890,8 +2917,9 @@ doCasByteArray
-> FCode ()
doCasByteArray res mba idx idx_ty old new = do
dflags <- getDynFlags
+ platform <- getPlatform
let width = (typeWidth idx_ty)
- addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+ addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)
width mba idx
emitPrimCall
[ res ]
@@ -2932,7 +2960,7 @@ emitMemcmpCall res ptr1 ptr2 n align = do
-- code-gens currently call out to the @memcmp(3)@ C function.
-- This was easier than moving the sign-extensions into
-- all the code-gens.
- dflags <- getDynFlags
+ platform <- getPlatform
let is32Bit = typeWidth (localRegType res) == W32
cres <- if is32Bit
@@ -2947,7 +2975,7 @@ emitMemcmpCall res ptr1 ptr2 n align = do
unless is32Bit $ do
emit $ mkAssign (CmmLocal res)
(CmmMachOp
- (mo_s_32ToWord dflags)
+ (mo_s_32ToWord platform)
[(CmmReg (CmmLocal cres))])
emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()
@@ -3005,15 +3033,15 @@ emitCtzCall res x width = do
-- | Push a range of pointer-array elements that are about to be copied over to
-- the update remembered set.
-emitCopyUpdRemSetPush :: DynFlags
+emitCopyUpdRemSetPush :: Platform
-> WordOff -- ^ array header size
-> CmmExpr -- ^ destination array
-> CmmExpr -- ^ offset in destination array (in words)
-> Int -- ^ number of elements to copy
-> FCode ()
-emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return ()
-emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =
- whenUpdRemSetEnabled dflags $ do
+emitCopyUpdRemSetPush _platform _hdr_size _dst _dst_off 0 = return ()
+emitCopyUpdRemSetPush platform hdr_size dst dst_off n =
+ whenUpdRemSetEnabled $ do
updfr_off <- getUpdFrameOff
graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []
emit graph
@@ -3021,8 +3049,8 @@ emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =
lbl = mkLblExpr $ mkPrimCallLabel
$ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId
args =
- [ mkIntExpr dflags hdr_size
+ [ mkIntExpr platform hdr_size
, dst
, dst_off
- , mkIntExpr dflags n
+ , mkIntExpr platform n
]
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index 86f20a71b9..c97bd793be 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -25,6 +25,7 @@ module GHC.StgToCmm.Prof (
import GhcPrelude
+import GHC.Platform
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
@@ -51,10 +52,10 @@ import Data.Char (ord)
-----------------------------------------------------------------------------
-- Expression representing the current cost centre stack
-ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
+ccsType :: Platform -> CmmType -- Type of a cost-centre stack
ccsType = bWord
-ccType :: DynFlags -> CmmType -- Type of a cost centre
+ccType :: Platform -> CmmType -- Type of a cost centre
ccType = bWord
storeCurCCS :: CmmExpr -> CmmAGraph
@@ -69,23 +70,29 @@ mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
costCentreFrom :: DynFlags
-> CmmExpr -- A closure pointer
-> CmmExpr -- The cost centre from that closure
-costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
+costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform)
+ where platform = targetPlatform dflags
-- | The profiling header words in a static closure
staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr dflags ccs
- = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
+ | gopt Opt_SccProfilingOn dflags = [mkCCostCentreStack ccs, staticLdvInit platform]
+ | otherwise = []
+ where platform = targetPlatform dflags
-- | Profiling header words in a dynamic closure
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
+dynProfHdr dflags ccs
+ | gopt Opt_SccProfilingOn dflags = [ccs, dynLdvInit dflags]
+ | otherwise = []
-- | Initialise the profiling field of an update frame
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf frame
= ifProfiling $ -- frame->header.prof.ccs = CCCS
do dflags <- getDynFlags
- emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
+ platform <- getPlatform
+ emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
-- is unnecessary because it is not used anyhow.
@@ -122,9 +129,10 @@ saveCurrentCostCentre :: FCode (Maybe LocalReg)
-- Returns Nothing if profiling is off
saveCurrentCostCentre
= do dflags <- getDynFlags
+ platform <- getPlatform
if not (gopt Opt_SccProfilingOn dflags)
then return Nothing
- else do local_cc <- newTemp (ccType dflags)
+ else do local_cc <- newTemp (ccType platform)
emitAssign (CmmLocal local_cc) cccsExpr
return (Just local_cc)
@@ -145,7 +153,8 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc rep ccs
= ifProfiling $
do dflags <- getDynFlags
- profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs
+ platform <- getPlatform
+ profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs
-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
@@ -154,12 +163,13 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc words ccs
= ifProfiling $
do dflags <- getDynFlags
+ platform <- getPlatform
let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
emit (addToMemE alloc_rep
- (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
- (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
- [CmmMachOp (mo_wordSub dflags) [words,
- mkIntExpr dflags (profHdrSize dflags)]]))
+ (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags))
+ (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $
+ [CmmMachOp (mo_wordSub platform) [words,
+ mkIntExpr platform (profHdrSize dflags)]]))
-- subtract the "profiling overhead", which is the
-- profiling header in a closure.
@@ -189,12 +199,6 @@ ifProfiling code
then code
else return ()
-ifProfilingL :: DynFlags -> [a] -> [a]
-ifProfilingL dflags xs
- | gopt Opt_SccProfilingOn dflags = xs
- | otherwise = []
-
-
---------------------------------------------------------------
-- Initialising Cost Centres & CCSs
---------------------------------------------------------------
@@ -211,8 +215,9 @@ initCostCentres (local_CCs, singleton_CCSs)
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc = do
{ dflags <- getDynFlags
- ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
- | otherwise = zero dflags
+ ; platform <- getPlatform
+ ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF
+ | otherwise = zero platform
-- NB. bytesFS: we want the UTF-8 bytes here (#5559)
; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
@@ -222,14 +227,14 @@ emitCostCentreDecl cc = do
showPpr dflags (costCentreSrcSpan cc)
-- XXX going via FastString to get UTF-8 encoding is silly
; let
- lits = [ zero dflags, -- StgInt ccID,
- label, -- char *label,
- modl, -- char *module,
- loc, -- char *srcloc,
- zero64, -- StgWord64 mem_alloc
- zero dflags, -- StgWord time_ticks
- is_caf, -- StgInt is_caf
- zero dflags -- struct _CostCentre *link
+ lits = [ zero platform, -- StgInt ccID,
+ label, -- char *label,
+ modl, -- char *module,
+ loc, -- char *srcloc,
+ zero64, -- StgWord64 mem_alloc
+ zero platform, -- StgWord time_ticks
+ is_caf, -- StgInt is_caf
+ zero platform -- struct _CostCentre *link
]
; emitRawDataLits (mkCCLabel cc) lits
}
@@ -239,9 +244,10 @@ emitCostCentreStackDecl ccs
= case maybeSingletonCCS ccs of
Just cc ->
do dflags <- getDynFlags
- let mk_lits cc = zero dflags :
+ platform <- getPlatform
+ let mk_lits cc = zero platform :
mkCCostCentre cc :
- replicate (sizeof_ccs_words dflags - 2) (zero dflags)
+ replicate (sizeof_ccs_words dflags - 2) (zero platform)
-- Note: to avoid making any assumptions about how the
-- C compiler (that compiles the RTS, in particular) does
-- layouts of structs containing long-longs, simply
@@ -250,8 +256,8 @@ emitCostCentreStackDecl ccs
emitRawDataLits (mkCCSLabel ccs) (mk_lits cc)
Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
-zero :: DynFlags -> CmmLit
-zero dflags = mkIntCLit dflags 0
+zero :: Platform -> CmmLit
+zero platform = mkIntCLit platform 0
zero64 :: CmmLit
zero64 = CmmInt 0 W64
@@ -261,7 +267,8 @@ sizeof_ccs_words dflags
| ms == 0 = ws
| otherwise = ws + 1
where
- (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
+ platform = targetPlatform dflags
+ (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
@@ -269,9 +276,10 @@ sizeof_ccs_words dflags
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC cc tick push
= do dflags <- getDynFlags
+ platform <- getPlatform
if not (gopt Opt_SccProfilingOn dflags)
then return ()
- else do tmp <- newTemp (ccsType dflags)
+ else do tmp <- newTemp (ccsType platform)
pushCostCentre tmp cccsExpr cc
when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
@@ -287,7 +295,8 @@ pushCostCentre result ccs cc
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount dflags ccs
= addToMem (rEP_CostCentreStack_scc_count dflags)
- (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
+ (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
+ where platform = targetPlatform dflags
-----------------------------------------------------------------------------
--
@@ -298,7 +307,7 @@ bumpSccCount dflags ccs
--
-- Initial value for the LDV field in a static closure
--
-staticLdvInit :: DynFlags -> CmmLit
+staticLdvInit :: Platform -> CmmLit
staticLdvInit = zeroCLit
--
@@ -306,10 +315,12 @@ staticLdvInit = zeroCLit
--
dynLdvInit :: DynFlags -> CmmExpr
dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
- CmmMachOp (mo_wordOr dflags) [
- CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
- CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
+ CmmMachOp (mo_wordOr platform) [
+ CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)],
+ CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags))
]
+ where
+ platform = targetPlatform dflags
--
-- Initialise the LDV word of a new closure
@@ -327,34 +338,39 @@ ldvRecordCreate closure = do
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure closure_info node_reg = do
dflags <- getDynFlags
+ platform <- getPlatform
let tag = funTag dflags closure_info
-- don't forget to subtract node's tag
- ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
+ ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))
ldvEnter :: CmmExpr -> FCode ()
-- Argument is a closure pointer
ldvEnter cl_ptr = do
dflags <- getDynFlags
+ platform <- getPlatform
let -- don't forget to subtract node's tag
ldv_wd = ldvWord dflags cl_ptr
- new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
- (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
- (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
+ new_ldv_wd = cmmOrWord platform
+ (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))
+ (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags))))
+ (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags))))
ifProfiling $
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-- era | LDV_STATE_USE }
- emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
+ emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)])
(mkStore ldv_wd new_ldv_wd)
mkNop
loadEra :: DynFlags -> CmmExpr
-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))
[CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
(cInt dflags)]
+ where platform = targetPlatform dflags
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
-- the address of the LDV word in the closure
ldvWord dflags closure_ptr
- = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ where platform = targetPlatform dflags
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 5968b9a944..44a1b10efb 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -106,6 +106,7 @@ module GHC.StgToCmm.Ticky (
import GhcPrelude
+import GHC.Platform
import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString )
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
@@ -211,6 +212,7 @@ emitTickyCounter cloType name args
(>> return ctr_lbl) $
ifTicky $ do
{ dflags <- getDynFlags
+ ; platform <- getPlatform
; parent <- getTickyCtrLabel
; mod_name <- getModuleName
@@ -246,14 +248,14 @@ emitTickyCounter cloType name args
-- krc: note that all the fields are I32 now; some were I16
-- before, but the code generator wasn't handling that
-- properly and it led to chaos, panic and disorder.
- [ mkIntCLit dflags 0, -- registered?
- mkIntCLit dflags (length args), -- Arity
- mkIntCLit dflags 0, -- Heap allocated for this thing
+ [ mkIntCLit platform 0, -- registered?
+ mkIntCLit platform (length args), -- Arity
+ mkIntCLit platform 0, -- Heap allocated for this thing
fun_descr_lit,
arg_descr_lit,
- zeroCLit dflags, -- Entries into this thing
- zeroCLit dflags, -- Heap allocated by this thing
- zeroCLit dflags -- Link to next StgEntCounter
+ zeroCLit platform, -- Entries into this thing
+ zeroCLit platform, -- Heap allocated by this thing
+ zeroCLit platform -- Link to next StgEntCounter
]
}
@@ -353,19 +355,20 @@ registerTickyCtr :: CLabel -> FCode ()
-- f_ct.registeredp = 1 }
registerTickyCtr ctr_lbl = do
dflags <- getDynFlags
+ platform <- getPlatform
let
-- krc: code generator doesn't handle Not, so we test for Eq 0 instead
- test = CmmMachOp (MO_Eq (wordWidth dflags))
+ test = CmmMachOp (MO_Eq (wordWidth platform))
[CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
- (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
- zeroExpr dflags]
+ (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform),
+ zeroExpr platform]
register_stmts
= [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
- (CmmLoad ticky_entry_ctrs (bWord dflags))
+ (CmmLoad ticky_entry_ctrs (bWord platform))
, mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
(oFFSET_StgEntCounter_registeredp dflags)))
- (mkIntExpr dflags 1) ]
+ (mkIntExpr platform 1) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
emit =<< mkCmmIfThen test (catAGraphs register_stmts)
@@ -493,24 +496,25 @@ tickyAllocHeap ::
tickyAllocHeap genuine hp
= ifTicky $
do { dflags <- getDynFlags
+ ; platform <- getPlatform
; ticky_ctr <- getTickyCtrLabel
; emit $ catAGraphs $
-- only test hp from within the emit so that the monadic
-- computation itself is not strict in hp (cf knot in
-- GHC.StgToCmm.Monad.getHeapUsage)
if hp == 0 then []
- else let !bytes = wORD_SIZE dflags * hp in [
+ else let !bytes = platformWordSizeInBytes platform * hp in [
-- Bump the allocation total in the closure's StgEntCounter
addToMem (rEP_StgEntCounter_allocs dflags)
(CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
bytes,
-- Bump the global allocation total ALLOC_HEAP_tot
- addToMemLbl (bWord dflags)
+ addToMemLbl (bWord platform)
(mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
bytes,
-- Bump the global allocation counter ALLOC_HEAP_ctr
if not genuine then mkNop
- else addToMemLbl (bWord dflags)
+ else addToMemLbl (bWord platform)
(mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
1
]}
@@ -607,23 +611,24 @@ bumpTickyLit lhs = bumpTickyLitBy lhs 1
bumpTickyLitBy :: CmmLit -> Int -> FCode ()
bumpTickyLitBy lhs n = do
- dflags <- getDynFlags
- emit (addToMem (bWord dflags) (CmmLit lhs) n)
+ platform <- getPlatform
+ emit (addToMem (bWord platform) (CmmLit lhs) n)
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE lhs e = do
- dflags <- getDynFlags
- emit (addToMemE (bWord dflags) (CmmLit lhs) e)
+ platform <- getPlatform
+ emit (addToMemE (bWord platform) (CmmLit lhs) e)
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram lbl n = do
dflags <- getDynFlags
+ platform <- getPlatform
let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
- emit (addToMem (bWord dflags)
- (cmmIndexExpr dflags
- (wordWidth dflags)
+ emit (addToMem (bWord platform)
+ (cmmIndexExpr platform
+ (wordWidth platform)
(CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
- (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
+ (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))
1)
------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index e576c2d95e..f212022822 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--
@@ -51,6 +52,7 @@ module GHC.StgToCmm.Utils (
import GhcPrelude
+import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import GHC.Cmm
@@ -97,25 +99,26 @@ import Data.Ord
cgLit :: Literal -> FCode CmmLit
cgLit (LitString s) = newByteStringCLit s
-- not unpackFS; we want the UTF-8 byte stream.
-cgLit other_lit = do dflags <- getDynFlags
- return (mkSimpleLit dflags other_lit)
-
-mkSimpleLit :: DynFlags -> Literal -> CmmLit
-mkSimpleLit dflags (LitChar c) = CmmInt (fromIntegral (ord c))
- (wordWidth dflags)
-mkSimpleLit dflags LitNullAddr = zeroCLit dflags
-mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
-mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
-mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
-mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
-mkSimpleLit _ (LitFloat r) = CmmFloat r W32
-mkSimpleLit _ (LitDouble r) = CmmFloat r W64
-mkSimpleLit _ (LitLabel fs ms fod)
- = let -- TODO: Literal labels might not actually be in the current package...
- labelSrc = ForeignLabelInThisPackage
- in CmmLabel (mkForeignLabel fs ms labelSrc fod)
--- NB: LitRubbish should have been lowered in "CoreToStg"
-mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
+cgLit other_lit = do platform <- getPlatform
+ return (mkSimpleLit platform other_lit)
+
+mkSimpleLit :: Platform -> Literal -> CmmLit
+mkSimpleLit platform = \case
+ (LitChar c) -> CmmInt (fromIntegral (ord c))
+ (wordWidth platform)
+ LitNullAddr -> zeroCLit platform
+ (LitNumber LitNumInt i _) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumInt64 i _) -> CmmInt i W64
+ (LitNumber LitNumWord i _) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumWord64 i _) -> CmmInt i W64
+ (LitFloat r) -> CmmFloat r W32
+ (LitDouble r) -> CmmFloat r W64
+ (LitLabel fs ms fod)
+ -> let -- TODO: Literal labels might not actually be in the current package...
+ labelSrc = ForeignLabelInThisPackage
+ in CmmLabel (mkForeignLabel fs ms labelSrc fod)
+ -- NB: LitRubbish should have been lowered in "CoreToStg"
+ other -> pprPanic "mkSimpleLit" (ppr other)
--------------------------------------------------------------------------
--
@@ -151,13 +154,13 @@ addToMemE rep ptr n
-------------------------------------------------------------------------
mkTaggedObjectLoad
- :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
+ :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
-- (loadTaggedObjectField reg base off tag) generates assignment
-- reg = bitsK[ base + off - tag ]
-- where K is fixed by 'reg'
-mkTaggedObjectLoad dflags reg base offset tag
+mkTaggedObjectLoad platform reg base offset tag
= mkAssign (CmmLocal reg)
- (CmmLoad (cmmOffsetB dflags
+ (CmmLoad (cmmOffsetB platform
(CmmReg (CmmLocal base))
(offset - tag))
(localRegType reg))
@@ -169,9 +172,9 @@ mkTaggedObjectLoad dflags reg base offset tag
--
-------------------------------------------------------------------------
-tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure dflags tycon tag
- = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
+tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure platform tycon tag
+ = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)
where closure_tbl = CmmLit (CmmLabel lbl)
lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
@@ -264,7 +267,7 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
callerRestoreGlobalReg reg
= mkAssign (CmmGlobal reg)
- (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
+ (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType platform reg))
-------------------------------------------------------------------------
@@ -338,9 +341,9 @@ assignTemp :: CmmExpr -> FCode LocalReg
-- due to them being trashed on foreign calls--though it means
-- the optimization pass doesn't have to do as much work)
assignTemp (CmmReg (CmmLocal reg)) = return reg
-assignTemp e = do { dflags <- getDynFlags
+assignTemp e = do { platform <- getPlatform
; uniq <- newUnique
- ; let reg = LocalReg uniq (cmmExprType dflags e)
+ ; let reg = LocalReg uniq (cmmExprType platform e)
; emitAssign (CmmLocal reg) e
; return reg }
@@ -355,15 +358,15 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- regs it wants will save later assignments.
newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
- do { dflags <- getDynFlags
+ do { platform <- getPlatform
; sequel <- getSequel
- ; regs <- choose_regs dflags sequel
+ ; regs <- choose_regs platform sequel
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
- choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
+ choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps
@@ -389,12 +392,12 @@ type Stmt = (LocalReg, CmmExpr) -- r := e
emitMultiAssign [] [] = return ()
emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
emitMultiAssign regs rhss = do
- dflags <- getDynFlags
+ platform <- getPlatform
ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
- unscramble dflags ([1..] `zip` (regs `zip` rhss))
+ unscramble platform ([1..] `zip` (regs `zip` rhss))
-unscramble :: DynFlags -> [Vrtx] -> FCode ()
-unscramble dflags vertices = mapM_ do_component components
+unscramble :: Platform -> [Vrtx] -> FCode ()
+unscramble platform vertices = mapM_ do_component components
where
edges :: [ Node Key Vrtx ]
edges = [ DigraphNode vertex key1 (edges_from stmt1)
@@ -417,25 +420,24 @@ unscramble dflags vertices = mapM_ do_component components
-- Cyclic? Then go via temporaries. Pick one to
-- break the loop and try again with the rest.
do_component (CyclicSCC ((_,first_stmt) : rest)) = do
- dflags <- getDynFlags
u <- newUnique
- let (to_tmp, from_tmp) = split dflags u first_stmt
+ let (to_tmp, from_tmp) = split u first_stmt
mk_graph to_tmp
- unscramble dflags rest
+ unscramble platform rest
mk_graph from_tmp
- split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
- split dflags uniq (reg, rhs)
+ split :: Unique -> Stmt -> (Stmt, Stmt)
+ split uniq (reg, rhs)
= ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
where
- rep = cmmExprType dflags rhs
+ rep = cmmExprType platform rhs
tmp = LocalReg uniq rep
mk_graph :: Stmt -> FCode ()
mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
mustFollow :: Stmt -> Stmt -> Bool
- (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
+ (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs
-------------------------------------------------------------------------
-- mkSwitch
@@ -519,7 +521,8 @@ emitCmmLitSwitch scrut branches deflt = do
branches_lbls <- label_branches join_lbl branches
dflags <- getDynFlags
- let cmm_ty = cmmExprType dflags scrut
+ platform <- getPlatform
+ let cmm_ty = cmmExprType platform scrut
rep = typeWidth cmm_ty
-- We find the necessary type information in the literals in the branches
@@ -551,28 +554,28 @@ mk_float_switch :: Width -> CmmExpr -> BlockId
-> [(Literal,BlockId)]
-> FCode CmmAGraph
mk_float_switch rep scrut deflt _bounds [(lit,blk)]
- = do dflags <- getDynFlags
- return $ mkCbranch (cond dflags) deflt blk Nothing
+ = do platform <- getPlatform
+ return $ mkCbranch (cond platform) deflt blk Nothing
where
- cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
+ cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit]
where
- cmm_lit = mkSimpleLit dflags lit
+ cmm_lit = mkSimpleLit platform lit
ne = MO_F_Ne rep
mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
- mkCmmIfThenElse (cond dflags) lo_blk hi_blk
+ mkCmmIfThenElse (cond platform) lo_blk hi_blk
where
(lo_branches, mid_lit, hi_branches) = divideBranches branches
bounds_lo = (lo_bound, Just mid_lit)
bounds_hi = (Just mid_lit, hi_bound)
- cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
+ cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit]
where
- cmm_lit = mkSimpleLit dflags mid_lit
+ cmm_lit = mkSimpleLit platform mid_lit
lt = MO_F_Lt rep
@@ -609,8 +612,8 @@ assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' e
| isTrivialCmmExpr e = return e
| otherwise = do
- dflags <- getDynFlags
- lreg <- newTemp (cmmExprType dflags e)
+ platform <- getPlatform
+ lreg <- newTemp (cmmExprType platform e)
let reg = CmmLocal lreg
emitAssign reg e
return (CmmReg reg)
@@ -620,15 +623,16 @@ assignTemp' e
-- Pushing to the update remembered set
---------------------------------------------------------------------------
-whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
-whenUpdRemSetEnabled dflags code = do
+whenUpdRemSetEnabled :: FCode a -> FCode ()
+whenUpdRemSetEnabled code = do
+ platform <- getPlatform
do_it <- getCode code
+ let
+ enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)
+ zero = zeroExpr platform
+ is_enabled = cmmNeWord platform enabled zero
the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
emit the_if
- where
- enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)
- zero = zeroExpr dflags
- is_enabled = cmmNeWord dflags enabled zero
-- | Emit code to add an entry to a now-overwritten pointer to the update
-- remembered set.