diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-09 19:59:01 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-03-19 12:16:49 -0400 |
| commit | 64f207566931469648e791df4f0f0384d45cddd0 (patch) | |
| tree | 58e8a6e27d192368b1ddbc47e9bb89046b2a24a4 /compiler | |
| parent | b03fd3bcd4ff14aed2942275c3b0db5392dc913c (diff) | |
| download | haskell-64f207566931469648e791df4f0f0384d45cddd0.tar.gz | |
Refactoring: use Platform instead of DynFlags when possible
Metric Decrease:
ManyConstructors
T12707
T13035
T1969
Diffstat (limited to 'compiler')
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. |