summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Cmm')
-rw-r--r--compiler/GHC/Cmm/CallConv.hs26
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs21
-rw-r--r--compiler/GHC/Cmm/Expr.hs110
-rw-r--r--compiler/GHC/Cmm/Graph.hs46
-rw-r--r--compiler/GHC/Cmm/Info.hs114
-rw-r--r--compiler/GHC/Cmm/Info/Build.hs3
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs136
-rw-r--r--compiler/GHC/Cmm/Lint.hs38
-rw-r--r--compiler/GHC/Cmm/MachOp.hs156
-rw-r--r--compiler/GHC/Cmm/Opt.hs91
-rw-r--r--compiler/GHC/Cmm/Parser.y26
-rw-r--r--compiler/GHC/Cmm/Pipeline.hs2
-rw-r--r--compiler/GHC/Cmm/Ppr.hs12
-rw-r--r--compiler/GHC/Cmm/Ppr/Decl.hs10
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs87
-rw-r--r--compiler/GHC/Cmm/Sink.hs55
-rw-r--r--compiler/GHC/Cmm/Switch/Implement.hs27
-rw-r--r--compiler/GHC/Cmm/Type.hs44
-rw-r--r--compiler/GHC/Cmm/Utils.hs259
19 files changed, 665 insertions, 598 deletions
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index 40f348f9e0..6cd66be30c 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -43,6 +43,7 @@ assignArgumentsPos :: DynFlags
assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
where
+ platform = targetPlatform dflags
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
@@ -57,7 +58,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
-- different type). When returning an unboxed tuple, we also
-- separate the stack arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs
- (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args
+ (stk_off, stk_assts) = assignStack platform off arg_ty stk_args
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
@@ -84,9 +85,9 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
- (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
+ (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
- (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
+ (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)
-> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
@@ -94,10 +95,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
- passFloatInXmm = passFloatArgsInXmm dflags
+ passFloatInXmm = passFloatArgsInXmm platform
-passFloatArgsInXmm :: DynFlags -> Bool
-passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+passFloatArgsInXmm :: Platform -> Bool
+passFloatArgsInXmm platform = case platformArch platform of
ArchX86_64 -> True
ArchX86 -> False
_ -> False
@@ -109,12 +110,12 @@ passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
passVectorInReg :: Width -> DynFlags -> Bool
passVectorInReg _ _ = True
-assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
-> (
ByteOff -- bytes of stack args
, [(a, ParamLocation)] -- args and locations
)
-assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)
where
assign_stk offset assts [] = (offset, assts)
assign_stk offset assts (r:rs)
@@ -123,7 +124,7 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
off' = offset + size
-- Stack arguments always take a whole number of words, we never
-- pack them unlike constructor fields.
- size = roundUpToWords dflags (widthInBytes w)
+ size = roundUpToWords platform (widthInBytes w)
-----------------------------------------------------------------------------
-- Local information about the registers available
@@ -202,9 +203,10 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
- | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
- realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
+ | passFloatArgsInXmm (targetPlatform dflags)
+ = map ($VGcPtr) (realVanillaRegs dflags) ++
+ realLongRegs dflags ++
+ map XmmReg (realXmmRegNos dflags)
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 23da957f9e..9d2da26b93 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -27,6 +27,7 @@ module GHC.Cmm.DebugBlock (
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
@@ -525,14 +526,14 @@ instance Outputable UnwindExpr where
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
-- possible.
-toUnwindExpr :: CmmExpr -> UnwindExpr
-toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
-toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l
-toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
-toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
-toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
-toUnwindExpr e@(CmmMachOp op [e1, e2]) =
- case (op, toUnwindExpr e1, toUnwindExpr e2) of
+toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
+toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
+toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l
+toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
+toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0
+toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)
+toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
+ case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
(MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
(MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
(MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
@@ -543,6 +544,6 @@ toUnwindExpr e@(CmmMachOp op [e1, e2]) =
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
- (pprExpr e)
-toUnwindExpr e
+ (pprExpr platform e)
+toUnwindExpr _ e
= pprPanic "Unsupported unwind expression!" (ppr e)
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index 9be4200f85..3c92c1e61b 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -32,6 +33,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
@@ -209,37 +211,39 @@ data CmmLit
-- of bytes used
deriving Eq
-cmmExprType :: DynFlags -> CmmExpr -> CmmType
-cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit
-cmmExprType _ (CmmLoad _ rep) = rep
-cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg
-cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
-cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg
-cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address
--- Careful though: what is stored at the stack slot may be bigger than
--- an address
-
-cmmLitType :: DynFlags -> CmmLit -> CmmType
-cmmLitType _ (CmmInt _ width) = cmmBits width
-cmmLitType _ (CmmFloat _ width) = cmmFloat width
-cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []"
-cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l
- in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
- then cmmVec (1+length ls) ty
- else panic "cmmLitType: CmmVec"
-cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
-cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
-cmmLitType _ (CmmLabelDiffOff _ _ _ width) = cmmBits width
-cmmLitType dflags (CmmBlock _) = bWord dflags
-cmmLitType dflags (CmmHighStackMark) = bWord dflags
-
-cmmLabelType :: DynFlags -> CLabel -> CmmType
-cmmLabelType dflags lbl
- | isGcPtrLabel lbl = gcWord dflags
- | otherwise = bWord dflags
-
-cmmExprWidth :: DynFlags -> CmmExpr -> Width
-cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
+cmmExprType :: Platform -> CmmExpr -> CmmType
+cmmExprType platform = \case
+ (CmmLit lit) -> cmmLitType platform lit
+ (CmmLoad _ rep) -> rep
+ (CmmReg reg) -> cmmRegType platform reg
+ (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
+ (CmmRegOff reg _) -> cmmRegType platform reg
+ (CmmStackSlot _ _) -> bWord platform -- an address
+ -- Careful though: what is stored at the stack slot may be bigger than
+ -- an address
+
+cmmLitType :: Platform -> CmmLit -> CmmType
+cmmLitType platform = \case
+ (CmmInt _ width) -> cmmBits width
+ (CmmFloat _ width) -> cmmFloat width
+ (CmmVec []) -> panic "cmmLitType: CmmVec []"
+ (CmmVec (l:ls)) -> let ty = cmmLitType platform l
+ in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)
+ then cmmVec (1+length ls) ty
+ else panic "cmmLitType: CmmVec"
+ (CmmLabel lbl) -> cmmLabelType platform lbl
+ (CmmLabelOff lbl _) -> cmmLabelType platform lbl
+ (CmmLabelDiffOff _ _ _ width) -> cmmBits width
+ (CmmBlock _) -> bWord platform
+ (CmmHighStackMark) -> bWord platform
+
+cmmLabelType :: Platform -> CLabel -> CmmType
+cmmLabelType platform lbl
+ | isGcPtrLabel lbl = gcWord platform
+ | otherwise = bWord platform
+
+cmmExprWidth :: Platform -> CmmExpr -> Width
+cmmExprWidth platform e = typeWidth (cmmExprType platform e)
-- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte.
@@ -278,12 +282,12 @@ instance Ord LocalReg where
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
-cmmRegType :: DynFlags -> CmmReg -> CmmType
-cmmRegType _ (CmmLocal reg) = localRegType reg
-cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
+cmmRegType :: Platform -> CmmReg -> CmmType
+cmmRegType _ (CmmLocal reg) = localRegType reg
+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
-cmmRegWidth :: DynFlags -> CmmReg -> Width
-cmmRegWidth dflags = typeWidth . cmmRegType dflags
+cmmRegWidth :: Platform -> CmmReg -> Width
+cmmRegWidth platform = typeWidth . cmmRegType platform
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
@@ -590,23 +594,23 @@ cccsReg = CmmGlobal CCCS
node :: GlobalReg
node = VanillaReg 1 VGcPtr
-globalRegType :: DynFlags -> GlobalReg -> CmmType
-globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags
-globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
-globalRegType _ (FloatReg _) = cmmFloat W32
-globalRegType _ (DoubleReg _) = cmmFloat W64
-globalRegType _ (LongReg _) = cmmBits W64
--- TODO: improve the internal model of SIMD/vectorized registers
--- the right design SHOULd improve handling of float and double code too.
--- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
-globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32)
-globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32)
-globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32)
-
-globalRegType dflags Hp = gcWord dflags
- -- The initialiser for all
- -- dynamically allocated closures
-globalRegType dflags _ = bWord dflags
+globalRegType :: Platform -> GlobalReg -> CmmType
+globalRegType platform = \case
+ (VanillaReg _ VGcPtr) -> gcWord platform
+ (VanillaReg _ VNonGcPtr) -> bWord platform
+ (FloatReg _) -> cmmFloat W32
+ (DoubleReg _) -> cmmFloat W64
+ (LongReg _) -> cmmBits W64
+ -- TODO: improve the internal model of SIMD/vectorized registers
+ -- the right design SHOULd improve handling of float and double code too.
+ -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
+ (XmmReg _) -> cmmVec 4 (cmmBits W32)
+ (YmmReg _) -> cmmVec 8 (cmmBits W32)
+ (ZmmReg _) -> cmmVec 16 (cmmBits W32)
+
+ Hp -> gcWord platform -- The initialiser for all
+ -- dynamically allocated closures
+ _ -> bWord platform
isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index c07f694897..413bce3f1e 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -310,15 +310,16 @@ copyIn :: DynFlags -> Convention -> Area
copyIn dflags conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where
+ platform = targetPlatform dflags
-- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg
global = CmmReg (CmmGlobal r)
- width = cmmRegWidth dflags local
+ width = cmmRegWidth platform local
expr
- | width == wordWidth dflags = global
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+ | width == wordWidth platform = global
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]
| otherwise = panic "Parameter width greater than word width"
in CmmAssign local expr
@@ -329,21 +330,21 @@ copyIn dflags conv area formals extra_stk
ci (reg, StackParam off)
| isBitsType $ localRegType reg
- , typeWidth (localRegType reg) < wordWidth dflags =
+ , typeWidth (localRegType reg) < wordWidth platform =
let
- stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+ stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))
local = CmmLocal reg
- width = cmmRegWidth dflags local
- expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
+ width = cmmRegWidth platform local
+ expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
in CmmAssign local expr
| otherwise =
CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
where ty = localRegType reg
- init_offset = widthInBytes (wordWidth dflags) -- infotable
+ init_offset = widthInBytes (wordWidth platform) -- infotable
- (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+ (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk
(stk_size, args) = assignArgumentsPos dflags stk_off conv
localRegType formals
@@ -370,15 +371,16 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
= (stk_size, regs, graph)
where
+ platform = targetPlatform dflags
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters]
co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
- let width = cmmExprWidth dflags v
+ let width = cmmExprWidth platform v
value
- | width == wordWidth dflags = v
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+ | width == wordWidth platform = v
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]
| otherwise = panic "Parameter width greater than word width"
in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
@@ -391,11 +393,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
co (v, StackParam off) (rs, ms)
= (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
- width v = cmmExprWidth dflags v
+ width v = cmmExprWidth platform v
value v
- | isBitsType $ cmmExprType dflags v
- , width v < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+ | isBitsType $ cmmExprType platform v
+ , width v < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]
| otherwise = v
(setRA, init_offset) =
@@ -405,20 +407,20 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
case transfer of
Call ->
([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
JumpRet ->
([],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
_other ->
([], 0)
Old -> ([], updfr_off)
(extra_stack_off, stack_params) =
- assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+ assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
(stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
- (cmmExprType dflags) actuals
+ (cmmExprType platform) actuals
-- Note [Width of parameters]
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 6b2a3d82c6..7a1bc2d3d1 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -194,7 +194,7 @@ mkInfoTableContents dflags
-- (which in turn came from a handwritten .cmm file)
| StackRep frame <- smrep
- = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+ = do { (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
; let
@@ -207,7 +207,7 @@ mkInfoTableContents dflags
| HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let layout = packIntsCLit dflags ptrs nonptrs
- ; (prof_lits, prof_data) <- mkProfLits dflags prof
+ ; (prof_lits, prof_data) <- mkProfLits platform prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
@@ -217,6 +217,7 @@ mkInfoTableContents dflags
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
where
+ platform = targetPlatform dflags
mk_pieces :: ClosureTypeInfo -> [CmmLit]
-> UniqSM ( Maybe CmmLit -- Override the SRT field with this
, Maybe CmmLit -- Override the layout field with this
@@ -225,15 +226,15 @@ mkInfoTableContents dflags
mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
= do { (descr_lit, decl) <- newStringLit con_descr
; return ( Just (CmmInt (fromIntegral con_tag)
- (halfWordWidth dflags))
+ (halfWordWidth platform))
, Nothing, [descr_lit], [decl]) }
mk_pieces Thunk srt_label
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
- = return (Just (CmmInt 0 (halfWordWidth dflags)),
- Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+ = return (Just (CmmInt 0 (halfWordWidth platform)),
+ Just (mkWordCLit platform (fromIntegral offset)), [], [])
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
@@ -251,7 +252,7 @@ mkInfoTableContents dflags
where
slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
srt_lit = case srt_label of
- [] -> mkIntCLit dflags 0
+ [] -> mkIntCLit platform 0
(lit:_rest) -> ASSERT( null _rest ) lit
mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
@@ -260,8 +261,9 @@ mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt
packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
packIntsCLit dflags a b = packHalfWordsCLit dflags
- (toStgHalfWord dflags (fromIntegral a))
- (toStgHalfWord dflags (fromIntegral b))
+ (toStgHalfWord platform (fromIntegral a))
+ (toStgHalfWord platform (fromIntegral b))
+ where platform = targetPlatform dflags
mkSRTLit :: DynFlags
@@ -271,9 +273,9 @@ mkSRTLit :: DynFlags
CmmLit) -- srt_bitmap
mkSRTLit dflags info_lbl (Just lbl)
| inlineSRT dflags
- = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
-mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth dflags))
-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+ = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth (targetPlatform dflags)))
+mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth (targetPlatform dflags)))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth (targetPlatform dflags)))
-- | Is the SRT offset field inline in the info table on this platform?
@@ -314,10 +316,10 @@ makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
| tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
+ = CmmLabelDiffOff lbl info_lbl 0 (wordWidth (targetPlatform dflags))
makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
| tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
+ = CmmLabelDiffOff lbl info_lbl off (wordWidth (targetPlatform dflags))
makeRelativeRefTo _ _ lit = lit
@@ -347,29 +349,30 @@ mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
-- 2. Large bitmap CmmData if needed
mkLivenessBits dflags liveness
- | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+ | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word
= do { uniq <- getUniqueM
; let bitmap_lbl = mkBitmapLabel uniq
; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word
- = return (mkStgWordCLit dflags bitmap_word, [])
+ = return (mkStgWordCLit platform bitmap_word, [])
where
+ platform = targetPlatform dflags
n_bits = length liveness
bitmap :: Bitmap
- bitmap = mkBitmap dflags liveness
+ bitmap = mkBitmap platform liveness
small_bitmap = case bitmap of
- [] -> toStgWord dflags 0
+ [] -> toStgWord platform 0
[b] -> b
_ -> panic "mkLiveness"
- bitmap_word = toStgWord dflags (fromIntegral n_bits)
+ bitmap_word = toStgWord platform (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
- lits = mkWordCLit dflags (fromIntegral n_bits)
- : map (mkStgWordCLit dflags) bitmap
+ lits = mkWordCLit platform (fromIntegral n_bits)
+ : map (mkStgWordCLit platform) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
@@ -402,11 +405,12 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
++ [layout_lit, tag, srt]
where
+ platform = targetPlatform dflags
prof_info
| gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = []
- tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+ tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)
-------------------------------------------------------------------------
--
@@ -414,8 +418,8 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
--
-------------------------------------------------------------------------
-mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
mkProfLits _ (ProfilingInfo td cd)
= do { (td_lit, td_decl) <- newStringLit td
; (cd_lit, cd_decl) <- newStringLit cd
@@ -430,8 +434,8 @@ newStringLit bytes
-- Misc utils
-- | Value of the srt field of an info table when using an StgLargeSRT
-srtEscape :: DynFlags -> StgHalfWord
-srtEscape dflags = toStgHalfWord dflags (-1)
+srtEscape :: Platform -> StgHalfWord
+srtEscape platform = toStgHalfWord platform (-1)
-------------------------------------------------------------------------
--
@@ -444,21 +448,22 @@ srtEscape dflags = toStgHalfWord dflags (-1)
wordAligned :: DynFlags -> CmmExpr -> CmmExpr
wordAligned dflags e
| gopt Opt_AlignmentSanitisation dflags
- = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+ = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
+ where platform = targetPlatform dflags
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
closureInfoPtr dflags e =
- CmmLoad (wordAligned dflags e) (bWord dflags)
+ CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns its entry code
entryCode dflags e
| tablesNextToCode dflags = e
- | otherwise = CmmLoad e (bWord dflags)
+ | otherwise = CmmLoad e (bWord (targetPlatform dflags))
getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
@@ -466,25 +471,28 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ platform = targetPlatform dflags
cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ platform = targetPlatform dflags
infoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
infoTable dflags info_ptr
- | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
- | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+ | tablesNextToCode dflags = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)
+ | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer
+ where platform = targetPlatform dflags
infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the constr tag
@@ -495,21 +503,25 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
infoTableSrtBitmap dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
infoTableClosureType dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTablePtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
infoTableNonPtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)
+ where platform = targetPlatform dflags
funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
@@ -517,16 +529,19 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
-- in the info table.
funInfoTable dflags info_ptr
| tablesNextToCode dflags
- = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+ = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
| otherwise
- = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
- -- Past the entry code pointer
+ = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)
+ -- Past the entry code pointer
+ where
+ platform = targetPlatform dflags
-- Takes the info pointer of a function, returns the function's arity
funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
funInfoArity dflags iptr
- = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+ = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
+ platform = targetPlatform dflags
fun_info = funInfoTable dflags iptr
rep = cmmBits (widthFromBytes rep_bytes)
@@ -572,20 +587,27 @@ maxRetInfoTableSizeW =
+ 1 {- srt label -}
stdInfoTableSizeB :: DynFlags -> ByteOff
-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
stdSrtBitmapOffset :: DynFlags -> ByteOff
-- Byte offset of the SRT bitmap half-word which is
-- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform
+ where platform = targetPlatform dflags
stdClosureTypeOffset :: DynFlags -> ByteOff
-- Byte offset of the closure type half-word
-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
-stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags
+stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
+
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform
+ where platform = targetPlatform dflags
conInfoTableSizeB :: DynFlags -> Int
-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform
+ where platform = targetPlatform dflags
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index 54a7d8fb91..274345ab7a 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -1086,12 +1086,13 @@ buildSRT dflags refs = do
id <- getUniqueM
let
lbl = mkSRTLabel id
+ platform = targetPlatform dflags
srt_n_info = mkSRTInfoLabel (length refs)
fields =
mkStaticClosure dflags srt_n_info dontCareCCS
[ CmmLabel lbl | SRTEntry lbl <- refs ]
[] -- no padding
- [mkIntCLit dflags 0] -- link field
+ [mkIntCLit platform 0] -- link field
[] -- no saved info
return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 2b6051dd38..ba480a25b7 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -29,6 +29,7 @@ import Maybes
import UniqFM
import Util
+import GHC.Platform
import GHC.Driver.Session
import FastString
import Outputable hiding ( isEmpty )
@@ -459,7 +460,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
- return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+ return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
-- one word of args: the return address
CmmBranch {} -> handleBranches
@@ -467,6 +468,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
CmmSwitch {} -> handleBranches
where
+ platform = targetPlatform dflags
-- Calls and ForeignCalls are handled the same way:
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
@@ -495,7 +497,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= (save_assignments, new_cont_stack)
where
(new_cont_stack, save_assignments)
- = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
+ = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0
-- For other last nodes (branches), if any of the targets is a
@@ -518,7 +520,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
out = mapFromList [ (l', cont_stack)
| l' <- successors last ]
return ( assigs
- , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
+ , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform)
, last
, []
, out)
@@ -552,7 +554,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= do
let cont_args = mapFindWithDefault 0 l cont_info
(stack2, assigs) =
- setupStackFrame dflags l liveness (sm_ret_off stack0)
+ setupStackFrame platform l liveness (sm_ret_off stack0)
cont_args stack0
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block)
@@ -609,7 +611,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
- :: DynFlags
+ :: Platform
-> BlockId -- label of continuation
-> LabelMap CmmLocalLive -- liveness
-> ByteOff -- updfr
@@ -617,7 +619,7 @@ setupStackFrame
-> StackMap -- current StackMap
-> (StackMap, [CmmNode O O])
-setupStackFrame dflags lbl liveness updfr_off ret_args stack0
+setupStackFrame platform lbl liveness updfr_off ret_args stack0
= (cont_stack, assignments)
where
-- get the set of LocalRegs live in the continuation
@@ -633,7 +635,7 @@ setupStackFrame dflags lbl liveness updfr_off ret_args stack0
-- everything up to updfr_off is off-limits
-- stack1 contains updfr_off, plus everything we need to save
- (stack1, assignments) = allocate dflags updfr_off live stack0
+ (stack1, assignments) = allocate platform updfr_off live stack0
-- And the Sp at the continuation is:
-- sm_sp stack1 + ret_args
@@ -714,9 +716,9 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
-allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
-allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
=
-- we only have to save regs that are not already in a slot
@@ -726,38 +728,38 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- make a map of the stack
let stack = reverse $ Array.elems $
- accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
+ accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $
ret_words ++ live_words
where ret_words =
[ (x, Occupied)
- | x <- [ 1 .. toWords dflags ret_off] ]
+ | x <- [ 1 .. toWords platform ret_off] ]
live_words =
- [ (toWords dflags x, Occupied)
+ [ (toWords platform x, Occupied)
| (r,off) <- nonDetEltsUFM regs1,
-- See Note [Unique Determinism and code generation]
- let w = localRegBytes dflags r,
- x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
+ let w = localRegBytes platform r,
+ x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ]
in
-- Pass over the stack: find slots to save all the new live variables,
-- choosing the oldest slots first (hence a foldr).
let
save slot ([], stack, n, assigs, regs) -- no more regs to save
- = ([], slot:stack, plusW dflags n 1, assigs, regs)
+ = ([], slot:stack, plusW platform n 1, assigs, regs)
save slot (to_save, stack, n, assigs, regs)
= case slot of
- Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
+ Occupied -> (to_save, Occupied:stack, plusW platform n 1, assigs, regs)
Empty
| Just (stack', r, to_save') <-
select_save to_save (slot:stack)
-> let assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
- n' = plusW dflags n 1
+ n' = plusW platform n 1
in
(to_save', stack', n', assig : assigs, (r,(r,n')):regs)
| otherwise
- -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
+ -> (to_save, slot:stack, plusW platform n 1, assigs, regs)
-- we should do better here: right now we'll fit the smallest first,
-- but it would make more sense to fit the biggest first.
@@ -770,7 +772,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
= Just (replicate words Occupied ++ rest, r, rs++no_fit)
| otherwise
= go rs (r:no_fit)
- where words = localRegWords dflags r
+ where words = localRegWords platform r
-- fill in empty slots as much as possible
(still_to_save, save_stack, n, save_assigs, save_regs)
@@ -783,14 +785,14 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
push r (n, assigs, regs)
= (n', assig : assigs, (r,(r,n')) : regs)
where
- n' = n + localRegBytes dflags r
+ n' = n + localRegBytes platform r
assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
trim_sp
| not (null push_regs) = push_sp
| otherwise
- = plusW dflags n (- length (takeWhile isEmpty save_stack))
+ = plusW platform n (- length (takeWhile isEmpty save_stack))
final_regs = regs1 `addListToUFM` push_regs
`addListToUFM` save_regs
@@ -799,7 +801,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- XXX should be an assert
if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
- if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+ if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, push_assigs ++ save_assigs )
@@ -838,10 +840,11 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
+ platform = targetPlatform dflags
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
- adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
- adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+ adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off)
+ adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off)
final_middle = maybeAddSpAdj dflags sp0 sp_off
. blockFromList
@@ -867,9 +870,10 @@ maybeAddSpAdj
maybeAddSpAdj dflags sp0 sp_off block =
add_initial_unwind $ add_adj_unwind $ adj block
where
+ platform = targetPlatform dflags
adj block
| sp_off /= 0
- = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+ = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)
| otherwise = block
-- Add unwind pseudo-instruction at the beginning of each block to
-- document Sp level for debugging
@@ -878,7 +882,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)
-- Add unwind pseudo-instruction right after the Sp adjustment
-- if there is one.
@@ -888,7 +892,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)
{- Note [SP old/young offsets]
@@ -908,23 +912,23 @@ arguments.
to be Sp + Sp(L) - Sp(L')
-}
-areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
- = cmmOffset dflags spExpr (sp_old - area_off area - n)
+areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)
+ = cmmOffset platform spExpr (sp_old - area_off area - n)
-- Replace (CmmStackSlot area n) with an offset from Sp
-areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
- = mkIntExpr dflags sp_hwm
+areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)
+ = mkIntExpr platform sp_hwm
-- Replace CmmHighStackMark with the number of bytes of stack used,
-- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args)
| falseStackCheck args
- = zeroExpr dflags
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
+ = zeroExpr platform
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args)
| falseStackCheck args
- = mkIntExpr dflags 1
+ = mkIntExpr platform 1
-- Replace a stack-overflow test that cannot fail with a no-op
-- See Note [Always false stack check]
@@ -1004,8 +1008,8 @@ elimStackStores stackmap stackmaps area_off nodes
-- Update info tables to include stack liveness
-setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
@@ -1016,18 +1020,18 @@ setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
- Just sm -> stackMapToLiveness dflags sm
+ Just sm -> stackMapToLiveness platform sm
setInfoTableStackMap _ _ d = d
-stackMapToLiveness :: DynFlags -> StackMap -> Liveness
-stackMapToLiveness dflags StackMap{..} =
+stackMapToLiveness :: Platform -> StackMap -> Liveness
+stackMapToLiveness platform StackMap{..} =
reverse $ Array.elems $
- accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
- toWords dflags (sm_sp - sm_args)) live_words
+ accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1,
+ toWords platform (sm_sp - sm_args)) live_words
where
- live_words = [ (toWords dflags off, False)
+ live_words = [ (toWords platform off, False)
| (r,off) <- nonDetEltsUFM sm_regs
, isGcPtrType (localRegType r) ]
-- See Note [Unique Determinism and code generation]
@@ -1050,6 +1054,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
let entry_label = entryLabel e_node
+ platform = targetPlatform dflags
stackmap = case mapLookup entry_label final_stackmaps of
Just sm -> sm
Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
@@ -1066,7 +1071,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
-- to a proc point.
(middle1, live_with_reloads)
| entry_label `setMember` procpoints
- = let reloads = insertReloads dflags stackmap live_at_middle0
+ = let reloads = insertReloads platform stackmap live_at_middle0
in (foldr blockCons middle0 reloads, emptyRegSet)
| otherwise
= (middle0, live_at_middle0)
@@ -1076,12 +1081,12 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
return (BlockCC e_node middle1 x_node, fact_base2)
-insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
-insertReloads dflags stackmap live =
+insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
+insertReloads platform stackmap live =
[ CmmAssign (CmmLocal reg)
-- This cmmOffset basically corresponds to manifesting
-- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
- (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
+ (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))
(localRegType reg))
| (reg, reg_off) <- stackSlotRegs stackmap
, reg `elemRegSet` live
@@ -1131,16 +1136,17 @@ lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
+ let platform = targetPlatform dflags
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
- id <- newTemp (bWord dflags)
- new_base <- newTemp (cmmRegType dflags baseReg)
+ id <- newTemp (bWord platform)
+ new_base <- newTemp (cmmRegType platform baseReg)
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
save_state_code <- saveThreadState dflags
load_state_code <- loadThreadState dflags
let suspend = save_state_code <*>
caller_save <*>
- mkMiddle (callSuspendThread dflags id intrbl)
+ mkMiddle (callSuspendThread platform id intrbl)
midCall = mkUnsafeCall tgt res args
resume = mkMiddle (callResumeThread new_base id) <*>
-- Assign the result to BaseReg: we
@@ -1160,10 +1166,10 @@ lowerSafeForeignCall dflags block
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = entryCode dflags $
- CmmLoad spExpr (bWord dflags)
+ CmmLoad spExpr (bWord platform)
, cml_cont = Just succ
, cml_args_regs = regs
- , cml_args = widthInBytes (wordWidth dflags)
+ , cml_args = widthInBytes (wordWidth platform)
, cml_ret_args = ret_args
, cml_ret_off = ret_off }
@@ -1185,12 +1191,12 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
-callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
-callSuspendThread dflags id intrbl =
+callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread platform id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
- [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
+ [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
@@ -1201,8 +1207,8 @@ callResumeThread new_base id =
-- -----------------------------------------------------------------------------
-plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
-plusW dflags b w = b + w * wORD_SIZE dflags
+plusW :: Platform -> ByteOff -> WordOff -> ByteOff
+plusW platform b w = b + w * platformWordSizeInBytes platform
data StackSlot = Occupied | Empty
-- Occupied: a return address or part of an update frame
@@ -1220,15 +1226,15 @@ isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
-localRegBytes :: DynFlags -> LocalReg -> ByteOff
-localRegBytes dflags r
- = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
+localRegBytes :: Platform -> LocalReg -> ByteOff
+localRegBytes platform r
+ = roundUpToWords platform (widthInBytes (typeWidth (localRegType r)))
-localRegWords :: DynFlags -> LocalReg -> WordOff
-localRegWords dflags = toWords dflags . localRegBytes dflags
+localRegWords :: Platform -> LocalReg -> WordOff
+localRegWords platform = toWords platform . localRegBytes platform
-toWords :: DynFlags -> ByteOff -> WordOff
-toWords dflags x = x `quot` wORD_SIZE dflags
+toWords :: Platform -> ByteOff -> WordOff
+toWords platform x = x `quot` platformWordSizeInBytes platform
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index a6bec1f187..5386f4421d 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -13,6 +13,7 @@ module GHC.Cmm.Lint (
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
@@ -91,27 +92,27 @@ lintCmmExpr (CmmLoad expr rep) = do
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
- dflags <- getDynFlags
+ platform <- getPlatform
tys <- mapM lintCmmExpr args
- if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+ if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+ else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
lintCmmExpr (CmmRegOff reg offset)
- = do dflags <- getDynFlags
- let rep = typeWidth (cmmRegType dflags reg)
+ = do platform <- getPlatform
+ let rep = typeWidth (cmmRegType platform reg)
lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
lintCmmExpr expr =
- do dflags <- getDynFlags
- return (cmmExprType dflags expr)
+ do platform <- getPlatform
+ return (cmmExprType platform expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
- = do dflags <- getDynFlags
- return (machOpResultType dflags op tys)
+ = do platform <- getPlatform
+ return (machOpResultType platform op tys)
{-
isOffsetOp :: MachOp -> Bool
@@ -145,9 +146,9 @@ lintCmmMiddle node = case node of
CmmUnwind{} -> return ()
CmmAssign reg expr -> do
- dflags <- getDynFlags
+ platform <- getPlatform
erep <- lintCmmExpr expr
- let reg_ty = cmmRegType dflags reg
+ let reg_ty = cmmRegType platform reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
@@ -167,16 +168,16 @@ lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id
CmmCondBranch e t f _ -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget [t,f]
_ <- lintCmmExpr e
- checkCond dflags e
+ checkCond platform e
CmmSwitch e ids -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget $ switchTargetsToList ids
erep <- lintCmmExpr e
- if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+ if (erep `cmmEqType_ignoring_ptrhood` bWord platform)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
ppr e <> text " :: " <> ppr erep)
@@ -200,9 +201,9 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget (PrimTarget {}) = return ()
-checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
checkCond _ expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@ -228,6 +229,9 @@ instance Monad CmmLint where
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
+getPlatform :: CmmLint Platform
+getPlatform = targetPlatform <$> getDynFlags
+
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (\_ -> Left msg)
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index d811d4808f..f1a1e9b699 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -30,9 +30,9 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Type
import Outputable
-import GHC.Driver.Session
-----------------------------------------------------------------------------
-- MachOp
@@ -172,60 +172,60 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
, mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
, mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
- :: DynFlags -> MachOp
+ :: Platform -> MachOp
mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
, mo_32To8, mo_32To16
:: MachOp
-mo_wordAdd dflags = MO_Add (wordWidth dflags)
-mo_wordSub dflags = MO_Sub (wordWidth dflags)
-mo_wordEq dflags = MO_Eq (wordWidth dflags)
-mo_wordNe dflags = MO_Ne (wordWidth dflags)
-mo_wordMul dflags = MO_Mul (wordWidth dflags)
-mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags)
-mo_wordSRem dflags = MO_S_Rem (wordWidth dflags)
-mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags)
-mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags)
-mo_wordURem dflags = MO_U_Rem (wordWidth dflags)
-
-mo_wordSGe dflags = MO_S_Ge (wordWidth dflags)
-mo_wordSLe dflags = MO_S_Le (wordWidth dflags)
-mo_wordSGt dflags = MO_S_Gt (wordWidth dflags)
-mo_wordSLt dflags = MO_S_Lt (wordWidth dflags)
-
-mo_wordUGe dflags = MO_U_Ge (wordWidth dflags)
-mo_wordULe dflags = MO_U_Le (wordWidth dflags)
-mo_wordUGt dflags = MO_U_Gt (wordWidth dflags)
-mo_wordULt dflags = MO_U_Lt (wordWidth dflags)
-
-mo_wordAnd dflags = MO_And (wordWidth dflags)
-mo_wordOr dflags = MO_Or (wordWidth dflags)
-mo_wordXor dflags = MO_Xor (wordWidth dflags)
-mo_wordNot dflags = MO_Not (wordWidth dflags)
-mo_wordShl dflags = MO_Shl (wordWidth dflags)
-mo_wordSShr dflags = MO_S_Shr (wordWidth dflags)
-mo_wordUShr dflags = MO_U_Shr (wordWidth dflags)
-
-mo_u_8To32 = MO_UU_Conv W8 W32
-mo_s_8To32 = MO_SS_Conv W8 W32
-mo_u_16To32 = MO_UU_Conv W16 W32
-mo_s_16To32 = MO_SS_Conv W16 W32
-
-mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags)
-mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags)
-mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags)
-mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags)
-mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags)
-mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags)
-
-mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8
-mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16
-mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32
-mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64
-
-mo_32To8 = MO_UU_Conv W32 W8
-mo_32To16 = MO_UU_Conv W32 W16
+mo_wordAdd platform = MO_Add (wordWidth platform)
+mo_wordSub platform = MO_Sub (wordWidth platform)
+mo_wordEq platform = MO_Eq (wordWidth platform)
+mo_wordNe platform = MO_Ne (wordWidth platform)
+mo_wordMul platform = MO_Mul (wordWidth platform)
+mo_wordSQuot platform = MO_S_Quot (wordWidth platform)
+mo_wordSRem platform = MO_S_Rem (wordWidth platform)
+mo_wordSNeg platform = MO_S_Neg (wordWidth platform)
+mo_wordUQuot platform = MO_U_Quot (wordWidth platform)
+mo_wordURem platform = MO_U_Rem (wordWidth platform)
+
+mo_wordSGe platform = MO_S_Ge (wordWidth platform)
+mo_wordSLe platform = MO_S_Le (wordWidth platform)
+mo_wordSGt platform = MO_S_Gt (wordWidth platform)
+mo_wordSLt platform = MO_S_Lt (wordWidth platform)
+
+mo_wordUGe platform = MO_U_Ge (wordWidth platform)
+mo_wordULe platform = MO_U_Le (wordWidth platform)
+mo_wordUGt platform = MO_U_Gt (wordWidth platform)
+mo_wordULt platform = MO_U_Lt (wordWidth platform)
+
+mo_wordAnd platform = MO_And (wordWidth platform)
+mo_wordOr platform = MO_Or (wordWidth platform)
+mo_wordXor platform = MO_Xor (wordWidth platform)
+mo_wordNot platform = MO_Not (wordWidth platform)
+mo_wordShl platform = MO_Shl (wordWidth platform)
+mo_wordSShr platform = MO_S_Shr (wordWidth platform)
+mo_wordUShr platform = MO_U_Shr (wordWidth platform)
+
+mo_u_8To32 = MO_UU_Conv W8 W32
+mo_s_8To32 = MO_SS_Conv W8 W32
+mo_u_16To32 = MO_UU_Conv W16 W32
+mo_s_16To32 = MO_SS_Conv W16 W32
+
+mo_u_8ToWord platform = MO_UU_Conv W8 (wordWidth platform)
+mo_s_8ToWord platform = MO_SS_Conv W8 (wordWidth platform)
+mo_u_16ToWord platform = MO_UU_Conv W16 (wordWidth platform)
+mo_s_16ToWord platform = MO_SS_Conv W16 (wordWidth platform)
+mo_s_32ToWord platform = MO_SS_Conv W32 (wordWidth platform)
+mo_u_32ToWord platform = MO_UU_Conv W32 (wordWidth platform)
+
+mo_WordTo8 platform = MO_UU_Conv (wordWidth platform) W8
+mo_WordTo16 platform = MO_UU_Conv (wordWidth platform) W16
+mo_WordTo32 platform = MO_UU_Conv (wordWidth platform) W32
+mo_WordTo64 platform = MO_UU_Conv (wordWidth platform) W64
+
+mo_32To8 = MO_UU_Conv W32 W8
+mo_32To16 = MO_UU_Conv W32 W16
-- ----------------------------------------------------------------------------
@@ -365,8 +365,8 @@ maybeInvertComparison op
{- |
Returns the MachRep of the result of a MachOp.
-}
-machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
-machOpResultType dflags mop tys =
+machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType
+machOpResultType platform mop tys =
case mop of
MO_Add {} -> ty1 -- Preserve GC-ptr-hood
MO_Sub {} -> ty1 -- of first arg
@@ -379,29 +379,29 @@ machOpResultType dflags mop tys =
MO_U_Quot r -> cmmBits r
MO_U_Rem r -> cmmBits r
- MO_Eq {} -> comparisonResultRep dflags
- MO_Ne {} -> comparisonResultRep dflags
- MO_S_Ge {} -> comparisonResultRep dflags
- MO_S_Le {} -> comparisonResultRep dflags
- MO_S_Gt {} -> comparisonResultRep dflags
- MO_S_Lt {} -> comparisonResultRep dflags
+ MO_Eq {} -> comparisonResultRep platform
+ MO_Ne {} -> comparisonResultRep platform
+ MO_S_Ge {} -> comparisonResultRep platform
+ MO_S_Le {} -> comparisonResultRep platform
+ MO_S_Gt {} -> comparisonResultRep platform
+ MO_S_Lt {} -> comparisonResultRep platform
- MO_U_Ge {} -> comparisonResultRep dflags
- MO_U_Le {} -> comparisonResultRep dflags
- MO_U_Gt {} -> comparisonResultRep dflags
- MO_U_Lt {} -> comparisonResultRep dflags
+ MO_U_Ge {} -> comparisonResultRep platform
+ MO_U_Le {} -> comparisonResultRep platform
+ MO_U_Gt {} -> comparisonResultRep platform
+ MO_U_Lt {} -> comparisonResultRep platform
MO_F_Add r -> cmmFloat r
MO_F_Sub r -> cmmFloat r
MO_F_Mul r -> cmmFloat r
MO_F_Quot r -> cmmFloat r
MO_F_Neg r -> cmmFloat r
- MO_F_Eq {} -> comparisonResultRep dflags
- MO_F_Ne {} -> comparisonResultRep dflags
- MO_F_Ge {} -> comparisonResultRep dflags
- MO_F_Le {} -> comparisonResultRep dflags
- MO_F_Gt {} -> comparisonResultRep dflags
- MO_F_Lt {} -> comparisonResultRep dflags
+ MO_F_Eq {} -> comparisonResultRep platform
+ MO_F_Ne {} -> comparisonResultRep platform
+ MO_F_Ge {} -> comparisonResultRep platform
+ MO_F_Le {} -> comparisonResultRep platform
+ MO_F_Gt {} -> comparisonResultRep platform
+ MO_F_Lt {} -> comparisonResultRep platform
MO_And {} -> ty1 -- Used for pointer masking
MO_Or {} -> ty1
@@ -445,7 +445,7 @@ machOpResultType dflags mop tys =
where
(ty1:_) = tys
-comparisonResultRep :: DynFlags -> CmmType
+comparisonResultRep :: Platform -> CmmType
comparisonResultRep = bWord -- is it?
@@ -457,8 +457,8 @@ comparisonResultRep = bWord -- is it?
-- its arguments are the same as the MachOp expects. This is used when
-- linting a CmmExpr.
-machOpArgReps :: DynFlags -> MachOp -> [Width]
-machOpArgReps dflags op =
+machOpArgReps :: Platform -> MachOp -> [Width]
+machOpArgReps platform op =
case op of
MO_Add r -> [r,r]
MO_Sub r -> [r,r]
@@ -499,9 +499,9 @@ machOpArgReps dflags op =
MO_Or r -> [r,r]
MO_Xor r -> [r,r]
MO_Not r -> [r]
- MO_Shl r -> [r, wordWidth dflags]
- MO_U_Shr r -> [r, wordWidth dflags]
- MO_S_Shr r -> [r, wordWidth dflags]
+ MO_Shl r -> [r, wordWidth platform]
+ MO_U_Shr r -> [r, wordWidth platform]
+ MO_S_Shr r -> [r, wordWidth platform]
MO_SS_Conv from _ -> [from]
MO_UU_Conv from _ -> [from]
@@ -510,8 +510,8 @@ machOpArgReps dflags op =
MO_FS_Conv from _ -> [from]
MO_FF_Conv from _ -> [from]
- MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]
- MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]
+ MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]
+ MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)),wordWidth platform]
MO_V_Add _ r -> [r,r]
MO_V_Sub _ r -> [r,r]
@@ -524,8 +524,8 @@ machOpArgReps dflags op =
MO_VU_Quot _ r -> [r,r]
MO_VU_Rem _ r -> [r,r]
- MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
- MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
+ MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]
+ MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]
MO_VF_Add _ r -> [r,r]
MO_VF_Sub _ r -> [r,r]
diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs
index 7dd43852a6..a217f71c47 100644
--- a/compiler/GHC/Cmm/Opt.hs
+++ b/compiler/GHC/Cmm/Opt.hs
@@ -17,7 +17,6 @@ import GhcPrelude
import GHC.Cmm.Utils
import GHC.Cmm
-import GHC.Driver.Session
import Util
import Outputable
@@ -27,12 +26,12 @@ import Data.Bits
import Data.Maybe
-constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
-constantFoldNode dflags = mapExp (constantFoldExpr dflags)
+constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
+constantFoldNode platform = mapExp (constantFoldExpr platform)
-constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
-constantFoldExpr dflags = wrapRecExp f
- where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
+constantFoldExpr platform = wrapRecExp f
+ where f (CmmMachOp op args) = cmmMachOpFold platform op args
f (CmmRegOff r 0) = CmmReg r
f e = e
@@ -43,17 +42,17 @@ constantFoldExpr dflags = wrapRecExp f
-- been optimized and folded.
cmmMachOpFold
- :: DynFlags
+ :: Platform
-> MachOp -- The operation from an CmmMachOp
-> [CmmExpr] -- The optimized arguments
-> CmmExpr
-cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
+cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
- :: DynFlags
+ :: Platform
-> MachOp
-> [CmmExpr]
-> Maybe CmmExpr
@@ -79,7 +78,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
-cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
+cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
| Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
Just (_, rep3,signed2) <- isIntConversion conv_outer
= case () of
@@ -89,13 +88,13 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but remember to use the signedness from the widening, just in case
-- the final conversion is a widen.
| rep1 < rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested widenings: collapse if the signedness is the same
| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested narrowings: collapse
| rep1 > rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]
| otherwise ->
Nothing
where
@@ -112,22 +111,22 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?
-cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
-- for comparisons: don't forget to narrow the arguments before
-- comparing, since they might be out of range.
- MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
- MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
+ MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))
+ MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))
- MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags))
- MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
- MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags))
- MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth platform))
+ MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))
+ MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth platform))
+ MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))
- MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags))
- MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
- MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags))
- MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth platform))
+ MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))
+ MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform))
+ MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))
MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
@@ -159,9 +158,9 @@ cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-- also assume that constants have been shifted to the right when
-- possible.
-cmmMachOpFoldM dflags op [x@(CmmLit _), y]
+cmmMachOpFoldM platform op [x@(CmmLit _), y]
| not (isLit y) && isCommutableMachOp op
- = Just (cmmMachOpFold dflags op [y, x])
+ = Just (cmmMachOpFold platform op [y, x])
-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
-- moved to the right, it is more likely that we will find
@@ -179,19 +178,19 @@ cmmMachOpFoldM dflags op [x@(CmmLit _), y]
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
-cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
| mop2 `associates_with` mop1
&& not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
+ = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])
where
MO_Add{} `associates_with` MO_Sub{} = True
mop1 `associates_with` mop2 =
mop1 == mop2 && isAssociativeMachOp mop1
-- special case: (a - b) + c ==> a + (c - b)
-cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
| not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
+ = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])
-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N)
--
@@ -234,9 +233,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
-- narrowing throws away bits from the operand, there's no way to do
-- the same comparison at the larger size.
-cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
| -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
- platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
+ platformArch platform `elem` [ArchX86, ArchX86_64],
-- if the operand is widened:
Just (rep, signed, narrow_fn) <- maybe_conversion conv,
-- and this is a comparison operation:
@@ -244,7 +243,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- and the literal fits in the smaller size:
i == narrow_fn rep i
-- then we can do the comparison at the smaller size
- = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
+ = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])
where
maybe_conversion (MO_UU_Conv from to)
| to > from
@@ -278,7 +277,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- We can often do something with constants of 0 and 1 ...
-- See Note [Comparison operators]
-cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]
= case mop of
-- Arithmetic
MO_Add _ -> Just x -- x + 0 = x
@@ -310,10 +309,10 @@ cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x'
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]
= case mop of
-- Arithmetic: x*1 = x, etc
MO_Mul _ -> Just x
@@ -336,27 +335,27 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
MO_S_Ge _ | isComparisonExpr x -> Just x
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-- Now look for multiplication/division by powers of 2 (integers).
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
= case mop of
MO_Mul rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
MO_U_Quot rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
MO_U_Rem rep
| Just _ <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+ Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
MO_S_Quot rep
| Just p <- exactLog2 n,
CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require
-- it is a reg. FIXME: remove this restriction.
- Just (cmmMachOpFold dflags (MO_S_Shr rep)
+ Just (cmmMachOpFold platform (MO_S_Shr rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
MO_S_Rem rep
| Just p <- exactLog2 n,
@@ -365,8 +364,8 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
-- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
-- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
-- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
- Just (cmmMachOpFold dflags (MO_Sub rep)
- [x, cmmMachOpFold dflags (MO_And rep)
+ Just (cmmMachOpFold platform (MO_Sub rep)
+ [x, cmmMachOpFold platform (MO_And rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
_ -> Nothing
where
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 95edf0693a..8609ca4a3a 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -770,7 +770,7 @@ expr0 :: { CmmParse CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
- : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags }
+ : {- empty -} {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }
| '::' type { $2 }
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
@@ -859,7 +859,7 @@ typenot8 :: { CmmType }
| 'bits512' { b512 }
| 'float32' { f32 }
| 'float64' { f64 }
- | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
+ | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }
{
section :: String -> SectionType
@@ -880,8 +880,9 @@ mkString s = CmmString (BS8.pack s)
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
mkMachOp fn args = do
dflags <- getDynFlags
+ let platform = targetPlatform dflags
arg_exprs <- sequence args
- return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
+ return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
@@ -1147,7 +1148,8 @@ reserveStackFrame psize preg body = do
old_updfr_off <- getUpdFrameOff
reg <- preg
esize <- psize
- let size = case constantFoldExpr dflags esize of
+ let platform = targetPlatform dflags
+ let size = case constantFoldExpr platform esize of
CmmLit (CmmInt n _) -> n
_other -> pprPanic "CmmParse: not a compile-time integer: "
(ppr esize)
@@ -1205,7 +1207,8 @@ mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
- (gcWord dflags))
+ (gcWord platform))
+ platform = targetPlatform dflags
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
@@ -1240,10 +1243,11 @@ adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
- | platformOS (targetPlatform dflags) == OSMinGW32
+ | platformOS platform == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+ where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType platform e)))
-- c.f. CgForeignCall.emitForeignCall
+ platform = targetPlatform dflags
adjCallTarget _ _ expr _
= expr
@@ -1271,8 +1275,9 @@ doStore rep addr_code val_code
-- mismatch to be flagged by cmm-lint. If we don't do this, then
-- the store will happen at the wrong type, and the error will not
-- be noticed.
- let val_width = typeWidth (cmmExprType dflags val)
+ let val_width = typeWidth (cmmExprType platform val)
rep_width = typeWidth rep
+ platform = targetPlatform dflags
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
| otherwise = val
@@ -1402,10 +1407,11 @@ forkLabelledCode p = do
initEnv :: DynFlags -> Env
initEnv dflags = listToUFM [
( fsLit "SIZEOF_StgHeader",
- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),
( fsLit "SIZEOF_StgInfoTable",
- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))
]
+ where platform = targetPlatform dflags
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index 88db550d8a..a2d47b3d48 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -138,7 +138,7 @@ cpsTop hsc_env proc =
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
- return $ map (setInfoTableStackMap dflags stackmaps) g
+ return $ map (setInfoTableStackMap platform stackmaps) g
dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
----------- Control-flow optimisations -----------------------------
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index 9f02cdcace..324fc8f1b1 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -42,6 +42,8 @@ where
import GhcPrelude hiding (succ)
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
@@ -67,7 +69,8 @@ instance Outputable CmmTopInfo where
instance Outputable (CmmNode e x) where
- ppr = pprNode
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprNode (targetPlatform dflags) e
instance Outputable Convention where
ppr = pprConvention
@@ -177,8 +180,8 @@ pprForeignTarget (PrimTarget op)
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction))
-pprNode :: CmmNode e x -> SDoc
-pprNode node = pp_node <+> pp_debug
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
where
pp_node :: SDoc
pp_node = case node of
@@ -209,8 +212,7 @@ pprNode node = pp_node <+> pp_debug
-- rep[lv] = expr;
CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
where
- rep = sdocWithDynFlags $ \dflags ->
- ppr ( cmmExprType dflags expr )
+ rep = ppr ( cmmExprType platform expr )
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index 6c19d5f7a6..6bece6dca8 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -40,6 +40,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Ppr.Expr
import GHC.Cmm
@@ -76,7 +77,8 @@ instance Outputable RawCmmStatics where
ppr = pprRawStatics
instance Outputable CmmStatic where
- ppr = pprStatic
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprStatic (targetPlatform dflags) e
instance Outputable CmmInfoTable where
ppr = pprInfoTable
@@ -148,9 +150,9 @@ pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds)
pprRawStatics :: RawCmmStatics -> SDoc
pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
- CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
+ CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index fbd4cdb7f1..9e25ededf6 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -41,6 +41,8 @@ where
import GhcPrelude
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
import GHC.Cmm.Expr
import Outputable
@@ -51,13 +53,15 @@ import Numeric ( fromRat )
-----------------------------------------------------------------------------
instance Outputable CmmExpr where
- ppr e = pprExpr e
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprExpr (targetPlatform dflags) e
instance Outputable CmmReg where
ppr e = pprReg e
instance Outputable CmmLit where
- ppr l = pprLit l
+ ppr l = sdocWithDynFlags $ \dflags ->
+ pprLit (targetPlatform dflags) l
instance Outputable LocalReg where
ppr e = pprLocalReg e
@@ -72,16 +76,15 @@ instance Outputable GlobalReg where
-- Expressions
--
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
- = sdocWithDynFlags $ \dflags ->
- case e of
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e
+ = case e of
CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
+ pprExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType dflags reg)
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
+ where rep = typeWidth (cmmRegType platform reg)
+ CmmLit lit -> pprLit platform lit
+ _other -> pprExpr1 platform e
-- Here's the precedence table from GHC.Cmm.Parser:
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
@@ -97,10 +100,11 @@ pprExpr e
-- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
+pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc
+pprExpr1 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp1 op
+ = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
+pprExpr1 platform e = pprExpr7 platform e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
@@ -115,55 +119,57 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<')
infixMachOp1 _ = Nothing
-- %left '-' '+'
-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp7 op
+ = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
+pprExpr7 platform e = pprExpr8 platform e
infixMachOp7 (MO_Add _) = Just (char '+')
infixMachOp7 (MO_Sub _) = Just (char '-')
infixMachOp7 _ = Nothing
-- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
+pprExpr8 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp8 op
+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
+pprExpr8 platform e = pprExpr9 platform e
infixMachOp8 (MO_U_Quot _) = Just (char '/')
infixMachOp8 (MO_Mul _) = Just (char '*')
infixMachOp8 (MO_U_Rem _) = Just (char '%')
infixMachOp8 _ = Nothing
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
+pprExpr9 :: Platform -> CmmExpr -> SDoc
+pprExpr9 platform e =
case e of
- CmmLit lit -> pprLit1 lit
+ CmmLit lit -> pprLit1 platform lit
CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp mop args
+ CmmMachOp mop args -> genMachOp platform mop args
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform mop args
| Just doc <- infixMachOp mop = case args of
-- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+ [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
-- unary
- [x] -> doc <> pprExpr9 x
+ [x] -> doc <> pprExpr9 platform x
_ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"
(pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))
empty
| isJust (infixMachOp1 mop)
|| isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
- | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
(show mop))
-- replace spaces in (show mop) with underscores,
@@ -187,16 +193,15 @@ infixMachOp mop
-- To minimise line noise we adopt the convention that if the literal
-- has the natural machine word size, we do not append the type
--
-pprLit :: CmmLit -> SDoc
-pprLit lit = sdocWithDynFlags $ \dflags ->
- case lit of
+pprLit :: Platform -> CmmLit -> SDoc
+pprLit platform lit = case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth dflags) $
+ , ppUnless (rep == wordWidth platform) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
- CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>'
+ CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
CmmLabel clbl -> ppr clbl
CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
@@ -204,9 +209,9 @@ pprLit lit = sdocWithDynFlags $ \dflags ->
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
+pprLit1 platform lit = pprLit platform lit
ppr_offset :: Int -> SDoc
ppr_offset i
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index ceb4f874ee..5dd7fac1d0 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -14,8 +14,8 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Platform.Regs
-import GHC.Platform (isARM, platformArch)
+import GHC.Platform
import GHC.Driver.Session
import Unique
import UniqFM
@@ -181,6 +181,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- pprTrace "sink" (ppr lbl) $
blockJoin first final_middle final_last : sink sunk' bs
where
+ platform = targetPlatform dflags
lbl = entryLabel b
(first, middle, last) = blockSplit b
@@ -195,7 +196,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- Now sink and inline in this block
(middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
- fold_last = constantFoldNode dflags last
+ fold_last = constantFoldNode platform last
(final_last, assigs') = tryToInline dflags live fold_last assigs
-- We cannot sink into join points (successors with more than
@@ -330,12 +331,13 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
where
go [] block as = (block, as)
go ((live,node):ns) block as
- | shouldDiscard node live = go ns block as
+ | shouldDiscard node live = go ns block as
-- discard dead assignment
- | Just a <- shouldSink dflags node2 = go ns block (a : as1)
- | otherwise = go ns block' as'
+ | Just a <- shouldSink platform node2 = go ns block (a : as1)
+ | otherwise = go ns block' as'
where
- node1 = constantFoldNode dflags node
+ platform = targetPlatform dflags
+ node1 = constantFoldNode platform node
(node2, as1) = tryToInline dflags live node1 as
@@ -351,8 +353,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
-shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
-shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
+shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
+shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e)
where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
shouldSink _ _other = Nothing
@@ -430,6 +432,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
| isTrivial dflags rhs = inline_and_keep
| otherwise = dont_inline
where
+ platform = targetPlatform dflags
inline_and_discard = go usages' inl_node skipped rest
where usages' = foldLocalRegsUsed dflags addUsage usages rhs
@@ -462,9 +465,9 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
-- inl_exp is where the inlining actually takes place!
inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs
inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
- = cmmOffset dflags rhs off
+ = cmmOffset platform rhs off
-- re-constant fold after inlining
- inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+ inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args
inl_exp other = other
@@ -588,7 +591,7 @@ conflicts dflags (r, rhs, addr) node
-- (3) a store to an address conflicts with a read of the same memory
| CmmStore addr' e <- node
- , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+ , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True
-- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
| HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True
@@ -603,19 +606,21 @@ conflicts dflags (r, rhs, addr) node
-- (7) otherwise, no conflict
| otherwise = False
+ where
+ platform = targetPlatform dflags
-- Returns True if node defines any global registers that are used in the
-- Cmm expression
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)
False node
-- Returns True if node defines any local registers that are used in the
-- Cmm expression
localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr)
False node
-- Note [Sinking and calls]
@@ -745,24 +750,24 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2)
| otherwise = o2 + w2 > o1
memConflicts _ _ = True
-exprMem :: DynFlags -> CmmExpr -> AbsMem
-exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
-exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es)
-exprMem _ _ = NoMem
+exprMem :: Platform -> CmmExpr -> AbsMem
+exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
+exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)
+exprMem _ _ = NoMem
-loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
-loadAddr dflags e w =
+loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
+loadAddr platform e w =
case e of
- CmmReg r -> regAddr dflags r 0 w
- CmmRegOff r i -> regAddr dflags r i w
- _other | regUsedIn dflags spReg e -> StackMem
- | otherwise -> AnyMem
+ CmmReg r -> regAddr platform r 0 w
+ CmmRegOff r i -> regAddr platform r i w
+ _other | regUsedIn platform spReg e -> StackMem
+ | otherwise -> AnyMem
-regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
regAddr _ (CmmGlobal Hp) _ _ = HeapMem
regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
-regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself
regAddr _ _ _ _ = AnyMem
{-
diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs
index 2074c465ad..7df32dd2e8 100644
--- a/compiler/GHC/Cmm/Switch/Implement.hs
+++ b/compiler/GHC/Cmm/Switch/Implement.hs
@@ -6,6 +6,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.BlockId
import GHC.Cmm
@@ -36,18 +37,18 @@ cmmImplementSwitchPlans dflags g
-- Switch generation done by backend (LLVM/C)
| targetSupportsSwitch (hscTarget dflags) = return g
| otherwise = do
- blocks' <- concatMapM (visitSwitches dflags) (toBlockList g)
+ blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
-visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
-visitSwitches dflags block
+visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches platform block
| (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block
= do
let plan = createSwitchPlan ids
-- See Note [Floating switch expressions]
- (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr
+ (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr
- (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan
+ (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan
let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail
@@ -71,16 +72,16 @@ visitSwitches dflags block
-- This happened in parts of the handwritten RTS Cmm code. See also #16933
-- See Note [Floating switch expressions]
-floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
-floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
-floatSwitchExpr dflags expr = do
- (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM
+floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
+floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
+floatSwitchExpr platform expr = do
+ (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM
return (BMiddle assign, expr')
-- Implementing a switch plan (returning a tail block)
-implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
-implementSwitchPlan dflags scope expr = go
+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan platform scope expr = go
where
go (Unconditionally l)
= return (emptyBlock `blockJoinTail` CmmBranch l, [])
@@ -93,7 +94,7 @@ implementSwitchPlan dflags scope expr = go
let lt | signed = cmmSLtWord
| otherwise = cmmULtWord
- scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
+ scrut = lt platform expr $ CmmLit $ mkWordCLit platform i
lastNode = CmmCondBranch scrut bid1 bid2 Nothing
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks1++newBlocks2)
@@ -101,7 +102,7 @@ implementSwitchPlan dflags scope expr = go
= do
(bid2, newBlocks2) <- go' ids2
- let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
+ let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i
lastNode = CmmCondBranch scrut bid2 l Nothing
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks2)
diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs
index 2fb4ea61a7..fced2bf076 100644
--- a/compiler/GHC/Cmm/Type.hs
+++ b/compiler/GHC/Cmm/Type.hs
@@ -31,6 +31,7 @@ where
import GhcPrelude
+import GHC.Platform
import GHC.Driver.Session
import FastString
import Outputable
@@ -120,14 +121,14 @@ f32 = cmmFloat W32
f64 = cmmFloat W64
-- CmmTypes of native word widths
-bWord :: DynFlags -> CmmType
-bWord dflags = cmmBits (wordWidth dflags)
+bWord :: Platform -> CmmType
+bWord platform = cmmBits (wordWidth platform)
-bHalfWord :: DynFlags -> CmmType
-bHalfWord dflags = cmmBits (halfWordWidth dflags)
+bHalfWord :: Platform -> CmmType
+bHalfWord platform = cmmBits (halfWordWidth platform)
-gcWord :: DynFlags -> CmmType
-gcWord dflags = CmmType GcPtrCat (wordWidth dflags)
+gcWord :: Platform -> CmmType
+gcWord platform = CmmType GcPtrCat (wordWidth platform)
cInt :: DynFlags -> CmmType
cInt dflags = cmmBits (cIntWidth dflags)
@@ -179,23 +180,20 @@ mrStr = sLit . show
-------- Common Widths ------------
-wordWidth :: DynFlags -> Width
-wordWidth dflags
- | wORD_SIZE dflags == 4 = W32
- | wORD_SIZE dflags == 8 = W64
- | otherwise = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth :: DynFlags -> Width
-halfWordWidth dflags
- | wORD_SIZE dflags == 4 = W16
- | wORD_SIZE dflags == 8 = W32
- | otherwise = panic "MachOp.halfWordRep: Unknown word size"
-
-halfWordMask :: DynFlags -> Integer
-halfWordMask dflags
- | wORD_SIZE dflags == 4 = 0xFFFF
- | wORD_SIZE dflags == 8 = 0xFFFFFFFF
- | otherwise = panic "MachOp.halfWordMask: Unknown word size"
+wordWidth :: Platform -> Width
+wordWidth platform = case platformWordSize platform of
+ PW4 -> W32
+ PW8 -> W64
+
+halfWordWidth :: Platform -> Width
+halfWordWidth platform = case platformWordSize platform of
+ PW4 -> W16
+ PW8 -> W32
+
+halfWordMask :: Platform -> Integer
+halfWordMask platform = case platformWordSize platform of
+ PW4 -> 0xFFFF
+ PW8 -> 0xFFFFFFFF
-- cIntRep is the Width for a C-language 'int'
cIntWidth :: DynFlags -> Width
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 53a1f095f8..4071bda9d5 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GADTs, RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -75,6 +76,7 @@ import GhcPrelude
import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 )
+import GHC.Platform
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.BlockId
@@ -98,31 +100,33 @@ import GHC.Cmm.Dataflow.Collections
--
---------------------------------------------------
-primRepCmmType :: DynFlags -> PrimRep -> CmmType
-primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
-primRepCmmType dflags LiftedRep = gcWord dflags
-primRepCmmType dflags UnliftedRep = gcWord dflags
-primRepCmmType dflags IntRep = bWord dflags
-primRepCmmType dflags WordRep = bWord dflags
-primRepCmmType _ Int8Rep = b8
-primRepCmmType _ Word8Rep = b8
-primRepCmmType _ Int16Rep = b16
-primRepCmmType _ Word16Rep = b16
-primRepCmmType _ Int32Rep = b32
-primRepCmmType _ Word32Rep = b32
-primRepCmmType _ Int64Rep = b64
-primRepCmmType _ Word64Rep = b64
-primRepCmmType dflags AddrRep = bWord dflags
-primRepCmmType _ FloatRep = f32
-primRepCmmType _ DoubleRep = f64
-primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
-
-slotCmmType :: DynFlags -> SlotTy -> CmmType
-slotCmmType dflags PtrSlot = gcWord dflags
-slotCmmType dflags WordSlot = bWord dflags
-slotCmmType _ Word64Slot = b64
-slotCmmType _ FloatSlot = f32
-slotCmmType _ DoubleSlot = f64
+primRepCmmType :: Platform -> PrimRep -> CmmType
+primRepCmmType platform = \case
+ VoidRep -> panic "primRepCmmType:VoidRep"
+ LiftedRep -> gcWord platform
+ UnliftedRep -> gcWord platform
+ IntRep -> bWord platform
+ WordRep -> bWord platform
+ Int8Rep -> b8
+ Word8Rep -> b8
+ Int16Rep -> b16
+ Word16Rep -> b16
+ Int32Rep -> b32
+ Word32Rep -> b32
+ Int64Rep -> b64
+ Word64Rep -> b64
+ AddrRep -> bWord platform
+ FloatRep -> f32
+ DoubleRep -> f64
+ (VecRep len rep) -> vec len (primElemRepCmmType rep)
+
+slotCmmType :: Platform -> SlotTy -> CmmType
+slotCmmType platform = \case
+ PtrSlot -> gcWord platform
+ WordSlot -> bWord platform
+ Word64Slot -> b64
+ FloatSlot -> f32
+ DoubleSlot -> f64
primElemRepCmmType :: PrimElemRep -> CmmType
primElemRepCmmType Int8ElemRep = b8
@@ -136,8 +140,8 @@ primElemRepCmmType Word64ElemRep = b64
primElemRepCmmType FloatElemRep = f32
primElemRepCmmType DoubleElemRep = f64
-typeCmmType :: DynFlags -> UnaryType -> CmmType
-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
+typeCmmType :: Platform -> UnaryType -> CmmType
+typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
@@ -176,20 +180,20 @@ typeForeignHint = primRepForeignHint . typePrimRep1
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
-mkIntCLit :: DynFlags -> Int -> CmmLit
-mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
+mkIntCLit :: Platform -> Int -> CmmLit
+mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)
-mkIntExpr :: DynFlags -> Int -> CmmExpr
-mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+mkIntExpr :: Platform -> Int -> CmmExpr
+mkIntExpr platform i = CmmLit $! mkIntCLit platform i
-zeroCLit :: DynFlags -> CmmLit
-zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+zeroCLit :: Platform -> CmmLit
+zeroCLit platform = CmmInt 0 (wordWidth platform)
-zeroExpr :: DynFlags -> CmmExpr
-zeroExpr dflags = CmmLit (zeroCLit dflags)
+zeroExpr :: Platform -> CmmExpr
+zeroExpr platform = CmmLit (zeroCLit platform)
-mkWordCLit :: DynFlags -> Integer -> CmmLit
-mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+mkWordCLit :: Platform -> Integer -> CmmLit
+mkWordCLit platform wd = CmmInt wd (wordWidth platform)
mkByteStringCLit
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
@@ -218,8 +222,8 @@ mkRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
-mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+mkStgWordCLit :: Platform -> StgWord -> CmmLit
+mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
-- Make a single word literal in which the lower_half_word is
@@ -229,10 +233,11 @@ packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
-- but be careful: that's vulnerable when reversed
packHalfWordsCLit dflags lower_half_word upper_half_word
= if wORDS_BIGENDIAN dflags
- then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)
- else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))
+ then mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
+ else mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
where l = fromStgHalfWord lower_half_word
u = fromStgHalfWord upper_half_word
+ platform = targetPlatform dflags
---------------------------------------------------
--
@@ -243,26 +248,23 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
-cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- assumes base and offset have the same CmmType
-cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
-cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
-
-cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
-cmmOffset _ e 0 = e
-cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
-cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
-cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
-cmmOffset _ (CmmStackSlot area off) byte_off
- = CmmStackSlot area (off - byte_off)
+cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)
+cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]
+
+cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr
+cmmOffset _platform e 0 = e
+cmmOffset platform e byte_off = case e of
+ CmmReg reg -> cmmRegOff reg byte_off
+ CmmRegOff reg m -> cmmRegOff reg (m+byte_off)
+ CmmLit lit -> CmmLit (cmmOffsetLit lit byte_off)
+ CmmStackSlot area off -> CmmStackSlot area (off - byte_off)
-- note stack area offsets increase towards lower addresses
-cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
- = CmmMachOp (MO_Add rep)
- [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
-cmmOffset dflags expr byte_off
- = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
- where
- width = cmmExprWidth dflags expr
+ CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]
+ -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]
+ _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]
+ where width = cmmExprWidth platform e
-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
@@ -284,37 +286,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
-- | Useful for creating an index into an array, with a statically known offset.
-- The type is the element type; used for making the multiplier
-cmmIndex :: DynFlags
+cmmIndex :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> Int -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
+cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)
-- | Useful for creating an index into an array, with an unknown offset.
-cmmIndexExpr :: DynFlags
+cmmIndexExpr :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> CmmExpr -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
-cmmIndexExpr dflags width base idx =
- cmmOffsetExpr dflags base byte_off
+cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)
+cmmIndexExpr platform width base idx =
+ cmmOffsetExpr platform base byte_off
where
- idx_w = cmmExprWidth dflags idx
- byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
+ idx_w = cmmExprWidth platform idx
+ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
-cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
+cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
-cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
-cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
@@ -326,25 +328,25 @@ cmmOffsetLitB = cmmOffsetLit
-----------------------
-- The "W" variants take word offsets
-cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
-cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
+cmmOffsetExprW platform e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)
+cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off
-cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
+cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)
-cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
-cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
+cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)
-cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
+cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)
-cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
-cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
+cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)
-cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
+cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty
-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
@@ -352,39 +354,41 @@ cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
- :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
-cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
-cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
-cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
-cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
-cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
-cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
-cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
-cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
-cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
-cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
-cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
-cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
-
-cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
-cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
-
-blankWord :: DynFlags -> CmmStatic
-blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
-
-cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
-cmmToWord dflags e
+ :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord platform e1 e2 = CmmMachOp (mo_wordOr platform) [e1, e2]
+cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]
+cmmNeWord platform e1 e2 = CmmMachOp (mo_wordNe platform) [e1, e2]
+cmmEqWord platform e1 e2 = CmmMachOp (mo_wordEq platform) [e1, e2]
+cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]
+cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]
+cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]
+cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]
+cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]
+cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]
+cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]
+cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]
+cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]
+
+cmmNegate :: Platform -> CmmExpr -> CmmExpr
+cmmNegate platform = \case
+ (CmmLit (CmmInt n rep))
+ -> CmmLit (CmmInt (-n) rep)
+ e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
+
+blankWord :: Platform -> CmmStatic
+blankWord platform = CmmUninitialised (platformWordSizeInBytes platform)
+
+cmmToWord :: Platform -> CmmExpr -> CmmExpr
+cmmToWord platform e
| w == word = e
| otherwise = CmmMachOp (MO_UU_Conv w word) [e]
where
- w = cmmExprWidth dflags e
- word = wordWidth dflags
+ w = cmmExprWidth platform e
+ word = wordWidth platform
-cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
-cmmMkAssign dflags expr uq =
- let !ty = cmmExprType dflags expr
+cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
+cmmMkAssign platform expr uq =
+ let !ty = cmmExprType platform expr
reg = (CmmLocal (LocalReg uq ty))
in (CmmAssign reg expr, CmmReg reg)
@@ -427,21 +431,24 @@ isComparisonExpr _ = False
-- Tag bits mask
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
-cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
-cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
+cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)
+cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
-- Default case
-cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
+cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)
+ where platform = targetPlatform dflags
-- Test if a closure pointer is untagged
-cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)
+ where platform = targetPlatform dflags
-- Get constructor tag, but one based.
-cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
+cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)
+ where platform = targetPlatform dflags
-----------------------------------------------------------------------------
@@ -451,10 +458,10 @@ cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
-- platform, in the sense that writing to one will clobber the
-- other. This includes the case that the two registers are the same
-- STG register. See Note [Overlapping global registers] for details.
-regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
-regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
- | Just real <- globalRegMaybe (targetPlatform dflags) g,
- Just real' <- globalRegMaybe (targetPlatform dflags) g',
+regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool
+regsOverlap platform (CmmGlobal g) (CmmGlobal g')
+ | Just real <- globalRegMaybe platform g,
+ Just real' <- globalRegMaybe platform g',
real == real'
= True
regsOverlap _ reg reg' = reg == reg'
@@ -467,12 +474,12 @@ regsOverlap _ reg reg' = reg == reg'
-- registers here, otherwise CmmSink may incorrectly reorder
-- assignments that conflict due to overlap. See #10521 and Note
-- [Overlapping global registers].
-regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
-regUsedIn dflags = regUsedIn_ where
+regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
+regUsedIn platform = regUsedIn_ where
_ `regUsedIn_` CmmLit _ = False
reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
- reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
- reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+ reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg'
+ reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
_ `regUsedIn_` CmmStackSlot _ _ = False
View Lorry Controller Status