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 ...@@ -164,6 +164,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 1: collect up the offsets of the local labels. -- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI dflags) instrs let asm = mapM_ (assembleI dflags) instrs
platform = targetPlatform dflags
initial_offset = 0 initial_offset = 0
-- Jump instructions are variable-sized, there are long and short variants -- Jump instructions are variable-sized, there are long and short variants
...@@ -174,9 +175,9 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm ...@@ -174,9 +175,9 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- and if the final size is indeed small enough for short jumps, we are -- 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 -- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long. -- 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) ((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) | otherwise = ((n_insns0, lbl_map0), False)
env :: Word16 -> Word env :: Word16 -> Word
...@@ -186,7 +187,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm ...@@ -186,7 +187,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 2: run assembler and generate instructions, literals and pointers -- pass 2: run assembler and generate instructions, literals and pointers
let initial_state = (emptySS, emptySS, emptySS) 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 -- precomputed size should be equal to final size
ASSERT(n_insns == sizeSS final_insns) return () ASSERT(n_insns == sizeSS final_insns) return ()
...@@ -265,8 +266,8 @@ largeOp long_jumps op = case op of ...@@ -265,8 +266,8 @@ largeOp long_jumps op = case op of
LabelOp _ -> long_jumps LabelOp _ -> long_jumps
-- LargeOp _ -> True -- LargeOp _ -> True
runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
runAsm dflags long_jumps e = go runAsm platform long_jumps e = go
where where
go (NullAsm x) = return x go (NullAsm x) = return x
go (AllocPtr p_io k) = do go (AllocPtr p_io k) = do
...@@ -289,8 +290,8 @@ runAsm dflags long_jumps e = go ...@@ -289,8 +290,8 @@ runAsm dflags long_jumps e = go
words = concatMap expand ops words = concatMap expand ops
expand (SmallOp w) = [w] expand (SmallOp w) = [w]
expand (LabelOp w) = expand (Op (e w)) expand (LabelOp w) = expand (Op (e w))
expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]
-- expand (LargeOp w) = largeArg dflags w -- expand (LargeOp w) = largeArg platform w
state $ \(st_i0,st_l0,st_p0) -> state $ \(st_i0,st_l0,st_p0) ->
let st_i1 = addListToSS st_i0 (opcode : words) let st_i1 = addListToSS st_i0 (opcode : words)
in ((), (st_i1,st_l0,st_p0)) in ((), (st_i1,st_l0,st_p0))
...@@ -305,8 +306,8 @@ data InspectState = InspectState ...@@ -305,8 +306,8 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap , lblEnv :: LabelEnvMap
} }
inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm dflags long_jumps initial_offset inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty) = go (InspectState initial_offset 0 0 Map.empty)
where where
go s (NullAsm _) = (instrCount s, lblEnv s) go s (NullAsm _) = (instrCount s, lblEnv s)
...@@ -323,8 +324,8 @@ inspectAsm dflags long_jumps initial_offset ...@@ -323,8 +324,8 @@ inspectAsm dflags long_jumps initial_offset
largeOps = any (largeOp long_jumps) ops largeOps = any (largeOp long_jumps) ops
count (SmallOp _) = 1 count (SmallOp _) = 1
count (LabelOp _) = count (Op 0) count (LabelOp _) = count (Op 0)
count (Op _) = if largeOps then largeArg16s dflags else 1 count (Op _) = if largeOps then largeArg16s platform else 1
-- count (LargeOp _) = largeArg16s dflags -- count (LargeOp _) = largeArg16s platform
-- Bring in all the bci_ bytecode constants. -- Bring in all the bci_ bytecode constants.
#include "rts/Bytecodes.h" #include "rts/Bytecodes.h"
...@@ -332,21 +333,19 @@ inspectAsm dflags long_jumps initial_offset ...@@ -332,21 +333,19 @@ inspectAsm dflags long_jumps initial_offset
largeArgInstr :: Word16 -> Word16 largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
largeArg :: DynFlags -> Word -> [Word16] largeArg :: Platform -> Word -> [Word16]
largeArg dflags w largeArg platform w = case platformWordSize platform of
| wORD_SIZE_IN_BITS dflags == 64 PW8 -> [fromIntegral (w `shiftR` 48),
= [fromIntegral (w `shiftR` 48), fromIntegral (w `shiftR` 32),
fromIntegral (w `shiftR` 32), fromIntegral (w `shiftR` 16),
fromIntegral (w `shiftR` 16), fromIntegral w]
fromIntegral w] PW4 -> [fromIntegral (w `shiftR` 16),
| wORD_SIZE_IN_BITS dflags == 32 fromIntegral w]
= [fromIntegral (w `shiftR` 16),
fromIntegral w] largeArg16s :: Platform -> Word
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" largeArg16s platform = case platformWordSize platform of
PW8 -> 4
largeArg16s :: DynFlags -> Word PW4 -> 2
largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
| otherwise = 2
assembleI :: DynFlags assembleI :: DynFlags
-> BCInstr -> BCInstr
......
...@@ -43,6 +43,7 @@ assignArgumentsPos :: DynFlags ...@@ -43,6 +43,7 @@ assignArgumentsPos :: DynFlags
assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
where where
platform = targetPlatform dflags
regs = case (reps, conv) of regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags (_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags (_, NativeDirectCall) -> getRegsWithoutNode dflags
...@@ -57,7 +58,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) ...@@ -57,7 +58,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
-- different type). When returning an unboxed tuple, we also -- different type). When returning an unboxed tuple, we also
-- separate the stack arguments by pointerhood. -- separate the stack arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs (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 assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, []) assign_regs assts [] _ = (assts, [])
...@@ -84,9 +85,9 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) ...@@ -84,9 +85,9 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
_ -> (assts, (r:rs)) _ -> (assts, (r:rs))
int = case (w, regs) of int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type" (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)) -> 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)) -> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs)) _ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
...@@ -94,10 +95,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) ...@@ -94,10 +95,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
w = typeWidth ty w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr | otherwise = VNonGcPtr
passFloatInXmm = passFloatArgsInXmm dflags passFloatInXmm = passFloatArgsInXmm platform
passFloatArgsInXmm :: DynFlags -> Bool passFloatArgsInXmm :: Platform -> Bool
passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of passFloatArgsInXmm platform = case platformArch platform of
ArchX86_64 -> True ArchX86_64 -> True
ArchX86 -> False ArchX86 -> False
_ -> False _ -> False
...@@ -109,12 +110,12 @@ passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of ...@@ -109,12 +110,12 @@ passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
passVectorInReg :: Width -> DynFlags -> Bool passVectorInReg :: Width -> DynFlags -> Bool
passVectorInReg _ _ = True passVectorInReg _ _ = True
assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
-> ( -> (
ByteOff -- bytes of stack args ByteOff -- bytes of stack args
, [(a, ParamLocation)] -- args and locations , [(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 where
assign_stk offset assts [] = (offset, assts) assign_stk offset assts [] = (offset, assts)
assign_stk offset assts (r:rs) assign_stk offset assts (r:rs)
...@@ -123,7 +124,7 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) ...@@ -123,7 +124,7 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
off' = offset + size off' = offset + size
-- Stack arguments always take a whole number of words, we never -- Stack arguments always take a whole number of words, we never
-- pack them unlike constructor fields. -- pack them unlike constructor fields.
size = roundUpToWords dflags (widthInBytes w) size = roundUpToWords platform (widthInBytes w)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Local information about the registers available -- Local information about the registers available
...@@ -202,9 +203,10 @@ nodeOnly = ([VanillaReg 1], [], [], [], []) ...@@ -202,9 +203,10 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- only use this functionality in hand-written C-- code in the RTS. -- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags realArgRegsCover dflags
| passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ | passFloatArgsInXmm (targetPlatform dflags)
realLongRegs dflags ++ = map ($VGcPtr) (realVanillaRegs dflags) ++
map XmmReg (realXmmRegNos dflags) realLongRegs dflags ++
map XmmReg (realXmmRegNos dflags)
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++ realFloatRegs dflags ++
realDoubleRegs dflags ++ realDoubleRegs dflags ++
......
...@@ -27,6 +27,7 @@ module GHC.Cmm.DebugBlock ( ...@@ -27,6 +27,7 @@ module GHC.Cmm.DebugBlock (
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Cmm.BlockId import GHC.Cmm.BlockId
import GHC.Cmm.CLabel import GHC.Cmm.CLabel
import GHC.Cmm import GHC.Cmm
...@@ -525,14 +526,14 @@ instance Outputable UnwindExpr where ...@@ -525,14 +526,14 @@ instance Outputable UnwindExpr where
-- | Conversion of Cmm expressions to unwind expressions. We check for -- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as -- unsupported operator usages and simplify the expression as far as
-- possible. -- possible.
toUnwindExpr :: CmmExpr -> UnwindExpr toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i) toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l
toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0 toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0
toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e) toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)
toUnwindExpr e@(CmmMachOp op [e1, e2]) = toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
case (op, toUnwindExpr e1, toUnwindExpr e2) of case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
(MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y) (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
(MO_Sub{}, 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) (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
...@@ -543,6 +544,6 @@ toUnwindExpr e@(CmmMachOp op [e1, e2]) = ...@@ -543,6 +544,6 @@ toUnwindExpr e@(CmmMachOp op [e1, e2]) =
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!" _otherwise -> pprPanic "Unsupported operator in unwind expression!"
(pprExpr e) (pprExpr platform e)
toUnwindExpr e toUnwindExpr _ e
= pprPanic "Unsupported unwind expression!" (ppr e) = pprPanic "Unsupported unwind expression!" (ppr e)
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
...@@ -32,6 +33,7 @@ where ...@@ -32,6 +33,7 @@ where
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Cmm.BlockId import GHC.Cmm.BlockId
import GHC.Cmm.CLabel import GHC.Cmm.CLabel
import GHC.Cmm.MachOp import GHC.Cmm.MachOp
...@@ -209,37 +211,39 @@ data CmmLit ...@@ -209,37 +211,39 @@ data CmmLit
-- of bytes used -- of bytes used
deriving Eq deriving Eq
cmmExprType :: DynFlags -> CmmExpr -> CmmType cmmExprType :: Platform -> CmmExpr -> CmmType
cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit cmmExprType platform = \case
cmmExprType _ (CmmLoad _ rep) = rep (CmmLit lit) -> cmmLitType platform lit
cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg (CmmLoad _ rep) -> rep
cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) (CmmReg reg) -> cmmRegType platform reg
cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address (CmmRegOff reg _) -> cmmRegType platform reg
-- Careful though: what is stored at the stack slot may be bigger than (CmmStackSlot _ _) -> bWord platform -- an address
-- 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 :: Platform -> CmmLit -> CmmType
cmmLitType _ (CmmFloat _ width) = cmmFloat width cmmLitType platform = \case
cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []" (CmmInt _ width) -> cmmBits width
cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l (CmmFloat _ width) -> cmmFloat width
in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls) (CmmVec []) -> panic "cmmLitType: CmmVec []"
then cmmVec (1+length ls) ty (CmmVec (l:ls)) -> let ty = cmmLitType platform l
else panic "cmmLitType: CmmVec" in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)
cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl then cmmVec (1+length ls) ty
cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl else panic "cmmLitType: CmmVec"
cmmLitType _ (CmmLabelDiffOff _ _ _ width) = cmmBits width (CmmLabel lbl) -> cmmLabelType platform lbl
cmmLitType dflags (CmmBlock _) = bWord dflags (CmmLabelOff lbl _) -> cmmLabelType platform lbl
cmmLitType dflags (CmmHighStackMark) = bWord dflags (CmmLabelDiffOff _ _ _ width) -> cmmBits width
(CmmBlock _) -> bWord platform
cmmLabelType :: DynFlags -> CLabel -> CmmType (CmmHighStackMark) -> bWord platform
cmmLabelType dflags lbl
| isGcPtrLabel lbl = gcWord dflags cmmLabelType :: Platform -> CLabel -> CmmType
| otherwise = bWord dflags cmmLabelType platform lbl
| isGcPtrLabel lbl = gcWord platform
cmmExprWidth :: DynFlags -> CmmExpr -> Width | otherwise = bWord platform
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
cmmExprWidth :: Platform -> CmmExpr -> Width
cmmExprWidth platform e = typeWidth (cmmExprType platform e)
-- | Returns an alignment in bytes of a CmmExpr when it's a statically -- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte. -- known integer constant, otherwise returns an alignment of 1 byte.
...@@ -278,12 +282,12 @@ instance Ord LocalReg where ...@@ -278,12 +282,12 @@ instance Ord LocalReg where
instance Uniquable LocalReg where instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq getUnique (LocalReg uniq _) = uniq
cmmRegType :: DynFlags -> CmmReg -> CmmType cmmRegType :: Platform -> CmmReg -> CmmType
cmmRegType _ (CmmLocal reg) = localRegType reg cmmRegType _ (CmmLocal reg) = localRegType reg
cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
cmmRegWidth :: DynFlags -> CmmReg -> Width cmmRegWidth :: Platform -> CmmReg -> Width
cmmRegWidth dflags = typeWidth . cmmRegType dflags cmmRegWidth platform = typeWidth . cmmRegType platform
localRegType :: LocalReg -> CmmType localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep localRegType (LocalReg _ rep) = rep
...@@ -590,23 +594,23 @@ cccsReg = CmmGlobal CCCS ...@@ -590,23 +594,23 @@ cccsReg = CmmGlobal CCCS
node :: GlobalReg node :: GlobalReg
node = VanillaReg 1 VGcPtr node = VanillaReg 1 VGcPtr
globalRegType :: DynFlags -> GlobalReg -> CmmType globalRegType :: Platform -> GlobalReg -> CmmType
globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags globalRegType platform = \case
globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags (VanillaReg _ VGcPtr) -> gcWord platform
globalRegType _ (FloatReg _) = cmmFloat W32 (VanillaReg _ VNonGcPtr) -> bWord platform
globalRegType _ (DoubleReg _) = cmmFloat W64 (FloatReg _) -> cmmFloat W32
globalRegType _ (LongReg _) = cmmBits W64 (DoubleReg _) -> cmmFloat W64
-- TODO: improve the internal model of SIMD/vectorized registers (LongReg _) -> cmmBits W64
-- the right design SHOULd improve handling of float and double code too. -- TODO: improve the internal model of SIMD/vectorized registers
-- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim -- the right design SHOULd improve handling of float and double code too.
globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32) -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
globalRegType _ (YmmReg _) = cmmVec 8 (cmmBits W32) (XmmReg _) -> cmmVec 4 (cmmBits W32)
globalRegType _ (ZmmReg _) = cmmVec 16 (cmmBits W32) (YmmReg _) -> cmmVec 8 (cmmBits W32)
(ZmmReg _) -> cmmVec 16 (cmmBits W32)
globalRegType dflags Hp = gcWord dflags
-- The initialiser for all Hp -> gcWord platform -- The initialiser for all
-- dynamically allocated closures -- dynamically allocated closures
globalRegType dflags _ = bWord dflags _ -> bWord platform
isArgReg :: GlobalReg -> Bool isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True isArgReg (VanillaReg {}) = True
......
...@@ -310,15 +310,16 @@ copyIn :: DynFlags -> Convention -> Area ...@@ -310,15 +310,16 @@ copyIn :: DynFlags -> Convention -> Area
copyIn dflags conv area formals extra_stk copyIn dflags conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where where
platform = targetPlatform dflags
-- See Note [Width of parameters] -- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) = ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg let local = CmmLocal reg
global = CmmReg (CmmGlobal r) global = CmmReg (CmmGlobal r)
width = cmmRegWidth dflags local width = cmmRegWidth platform local
expr expr
| width == wordWidth dflags = global | width == wordWidth platform = global
| width < wordWidth dflags = | width < wordWidth platform =
CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global] CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]
| otherwise = panic "Parameter width greater than word width" | otherwise = panic "Parameter width greater than word width"
in CmmAssign local expr in CmmAssign local expr
...@@ -329,21 +330,21 @@ copyIn dflags conv area formals extra_stk ...@@ -329,21 +330,21 @@ copyIn dflags conv area formals extra_stk
ci (reg, StackParam off) ci (reg, StackParam off)
| isBitsType $ localRegType reg | isBitsType $ localRegType reg
, typeWidth (localRegType reg) < wordWidth dflags = , typeWidth (localRegType reg) < wordWidth platform =
let let
stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags)) stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))
local = CmmLocal reg local = CmmLocal reg
width = cmmRegWidth dflags local width = cmmRegWidth platform local
expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot] expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
in CmmAssign local expr in CmmAssign local expr
| otherwise = | otherwise =
CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
where ty = localRegType reg 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 (stk_size, args) = assignArgumentsPos dflags stk_off conv
localRegType formals localRegType formals
...@@ -370,15 +371,16 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] ...@@ -370,15 +371,16 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
= (stk_size, regs, graph) = (stk_size, regs, graph)
where where
platform = targetPlatform dflags
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters] -- See Note [Width of parameters]
co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
let width = cmmExprWidth dflags v let width = cmmExprWidth platform v
value value
| width == wordWidth dflags = v | width == wordWidth platform = v
| width < wordWidth dflags = | width < wordWidth platform =
CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v] CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]
| otherwise = panic "Parameter width greater than word width" | otherwise = panic "Parameter width greater than word width"
in (r:rs, mkAssign (CmmGlobal r) value <*> ms) in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
...@@ -391,11 +393,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff ...@@ -391,11 +393,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
co (v, StackParam off) (rs, ms) co (v, StackParam off) (rs, ms)
= (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
width v = cmmExprWidth dflags v width v = cmmExprWidth platform v
value v value v
| isBitsType $ cmmExprType dflags v | isBitsType $ cmmExprType platform v
, width v < wordWidth dflags = , width v < wordWidth platform =
CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v] CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]
| otherwise = v | otherwise = v
(setRA, init_offset) = (setRA, init_offset) =
...@@ -405,20 +407,20 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff ...@@ -405,20 +407,20 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
case transfer of case transfer of
Call -> Call ->
([(CmmLit (CmmBlock id), StackParam init_offset)], ([(CmmLit (CmmBlock id), StackParam init_offset)],
widthInBytes (wordWidth dflags)) widthInBytes (wordWidth platform))
JumpRet -> JumpRet ->
([], ([],
widthInBytes (wordWidth dflags)) widthInBytes (wordWidth platform))
_other -> _other ->
([], 0) ([], 0)
Old -> ([], updfr_off) Old -> ([], updfr_off)
(extra_stack_off, stack_params) = (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 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
(stk_size, args) = assignArgumentsPos dflags extra_stack_off conv (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
(cmmExprType dflags) actuals (cmmExprType platform) actuals
-- Note [Width of parameters] -- Note [Width of parameters]
......
This diff is collapsed.
...@@ -1086,12 +1086,13 @@ buildSRT dflags refs = do ...@@ -1086,12 +1086,13 @@ buildSRT dflags refs = do
id <- getUniqueM id <- getUniqueM
let let
lbl = mkSRTLabel id lbl = mkSRTLabel id
platform = targetPlatform dflags
srt_n_info = mkSRTInfoLabel (length refs) srt_n_info = mkSRTInfoLabel (length refs)
fields = fields =
mkStaticClosure dflags srt_n_info dontCareCCS mkStaticClosure dflags srt_n_info dontCareCCS
[ CmmLabel lbl | SRTEntry lbl <- refs ] [ CmmLabel lbl | SRTEntry lbl <- refs ]
[] -- no padding [] -- no padding
[mkIntCLit dflags 0] -- link field [mkIntCLit platform 0] -- link field
[] -- no saved info [] -- no saved info
return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
......
This diff is collapsed.
...@@ -13,6 +13,7 @@ module GHC.Cmm.Lint ( ...@@ -13,6 +13,7 @@ module GHC.Cmm.Lint (
import GhcPrelude import GhcPrelude
import GHC.Platform
import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Graph
...@@ -91,27 +92,27 @@ lintCmmExpr (CmmLoad expr rep) = do ...@@ -91,27 +92,27 @@ lintCmmExpr (CmmLoad expr rep) = do
-- cmmCheckWordAddress expr -- cmmCheckWordAddress expr
return rep return rep
lintCmmExpr expr@(CmmMachOp op args) = do lintCmmExpr expr@(CmmMachOp op args) = do
dflags <- getDynFlags platform