Skip to content
Commits on Source (2)
  • Sylvain Henry's avatar
    Refactoring: use Platform instead of DynFlags when possible · 64f20756
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed 
    Metric Decrease:
    ManyConstructors
    T12707
    T13035
    T1969
    64f20756
  • Ömer Sinan Ağacan's avatar
    FastString: fix eager reading of string ptr in hashStr · cb1785d9
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed 
    This read causes NULL dereferencing when len is 0.

Fixes #17909

In the reproducer in #17909 this bug is triggered as follows:

- SimplOpt.dealWithStringLiteral is called with a single-char string
  ("=" in #17909)

- tailFS gets called on the FastString of the single-char string.

- tailFS checks the length of the string, which is 1, and calls
  mkFastStringByteString on the tail of the ByteString, which is an
  empty ByteString as the original ByteString has only one char.

- ByteString's unsafeUseAsCStringLen returns (NULL, 0) for the empty
  ByteString, which is passed to mkFastStringWith.

- mkFastStringWith gets hash of the NULL pointer via hashStr, which
  fails on empty strings because of this bug.
    cb1785d9
Hide whitespace changes
Inline Side-by-side
compiler/GHC/ByteCode/Asm.hs
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/CallConv.hs
View file @ cb1785d9
......@@ -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 ++
......
compiler/GHC/Cmm/DebugBlock.hs
View file @ cb1785d9
......@@ -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)
compiler/GHC/Cmm/Expr.hs
View file @ cb1785d9
{-# 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
......
compiler/GHC/Cmm/Graph.hs
View file @ cb1785d9
......@@ -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]
......
compiler/GHC/Cmm/Info.hs
View file @ cb1785d9
......@@ -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
compiler/GHC/Cmm/Info/Build.hs
View file @ cb1785d9
......@@ -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)
......
compiler/GHC/Cmm/LayoutStack.hs
View file @ cb1785d9
......@@ -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)]
......
compiler/GHC/Cmm/Lint.hs
View file @ cb1785d9
......@@ -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)
......
compiler/GHC/Cmm/MachOp.hs
View file @ cb1785d9
......@@ -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]
......
compiler/GHC/Cmm/Opt.hs
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/Parser.y
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/Pipeline.hs
View file @ cb1785d9
......@@ -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 -----------------------------
......
compiler/GHC/Cmm/Ppr.hs
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/Ppr/Decl.hs
View file @ cb1785d9
......@@ -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')
......
compiler/GHC/Cmm/Ppr/Expr.hs
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/Sink.hs
View file @ cb1785d9
......@@ -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
{-
......
compiler/GHC/Cmm/Switch/Implement.hs
View file @ cb1785d9
......@@ -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)
......
compiler/GHC/Cmm/Type.hs
View file @ cb1785d9
......@@ -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
......
compiler/GHC/Cmm/Utils.hs
View file @ cb1785d9
{-# 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
......