Commit 64f20756 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactoring: use Platform instead of DynFlags when possible

Metric Decrease:
    ManyConstructors
    T12707
    T13035
    T1969
parent b03fd3bc
......@@ -164,6 +164,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs
platform = targetPlatform dflags
initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants
......@@ -174,9 +175,9 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- and if the final size is indeed small enough for short jumps, we are
-- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long.
(n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
(n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
((n_insns, lbl_map), long_jumps)
| isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
| isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)
| otherwise = ((n_insns0, lbl_map0), False)
env :: Word16 -> Word
......@@ -186,7 +187,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 2: run assembler and generate instructions, literals and pointers
let initial_state = (emptySS, emptySS, emptySS)
(final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
(final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
-- precomputed size should be equal to final size
ASSERT(n_insns == sizeSS final_insns) return ()
......@@ -265,8 +266,8 @@ largeOp long_jumps op = case op of
LabelOp _ -> long_jumps
-- LargeOp _ -> True
runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
runAsm dflags long_jumps e = go
runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
runAsm platform long_jumps e = go
where
go (NullAsm x) = return x
go (AllocPtr p_io k) = do
......@@ -289,8 +290,8 @@ runAsm dflags long_jumps e = go
words = concatMap expand ops
expand (SmallOp w) = [w]
expand (LabelOp w) = expand (Op (e w))
expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
-- expand (LargeOp w) = largeArg dflags w
expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]
-- expand (LargeOp w) = largeArg platform w
state $ \(st_i0,st_l0,st_p0) ->
let st_i1 = addListToSS st_i0 (opcode : words)
in ((), (st_i1,st_l0,st_p0))
......@@ -305,8 +306,8 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm dflags long_jumps initial_offset
inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
where
go s (NullAsm _) = (instrCount s, lblEnv s)
......@@ -323,8 +324,8 @@ inspectAsm dflags long_jumps initial_offset
largeOps = any (largeOp long_jumps) ops
count (SmallOp _) = 1
count (LabelOp _) = count (Op 0)
count (Op _) = if largeOps then largeArg16s dflags else 1
-- count (LargeOp _) = largeArg16s dflags
count (Op _) = if largeOps then largeArg16s platform else 1
-- count (LargeOp _) = largeArg16s platform
-- Bring in all the bci_ bytecode constants.
#include "rts/Bytecodes.h"
......@@ -332,21 +333,19 @@ inspectAsm dflags long_jumps initial_offset
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
largeArg :: DynFlags -> Word -> [Word16]
largeArg dflags w
| wORD_SIZE_IN_BITS dflags == 64
= [fromIntegral (w `shiftR` 48),
fromIntegral (w `shiftR` 32),
fromIntegral (w `shiftR` 16),
fromIntegral w]
| wORD_SIZE_IN_BITS dflags == 32
= [fromIntegral (w `shiftR` 16),
fromIntegral w]
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
largeArg16s :: DynFlags -> Word
largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
| otherwise = 2
largeArg :: Platform -> Word -> [Word16]
largeArg platform w = case platformWordSize platform of
PW8 -> [fromIntegral (w `shiftR` 48),
fromIntegral (w `shiftR` 32),
fromIntegral (w `shiftR` 16),
fromIntegral w]
PW4 -> [fromIntegral (w `shiftR` 16),
fromIntegral w]
largeArg16s :: Platform -> Word
largeArg16s platform = case platformWordSize platform of
PW8 -> 4
PW4 -> 2
assembleI :: DynFlags
-> BCInstr
......
......@@ -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 ++
......
......@@ -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)
{-# 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
......
......@@ -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]
......
This diff is collapsed.
......@@ -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)
......
This diff is collapsed.
......@@ -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)
......
......@@ -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)
<