Commit f611396a authored by ian@well-typed.com's avatar ian@well-typed.com

Pass DynFlags down to bWord

I've switched to passing DynFlags rather than Platform, as (a) it's
simpler to not have to extract targetPlatform in so many places, and
(b) it may be useful to have DynFlags around in future.
parent 6986eb91
......@@ -23,6 +23,7 @@ import CmmType
import CmmMachOp
import BlockId
import CLabel
import DynFlags
import Unique
import Data.Set (Set)
......@@ -111,31 +112,32 @@ data CmmLit
| CmmHighStackMark -- stands for the max stack space used during a procedure
deriving Eq
cmmExprType :: CmmExpr -> CmmType
cmmExprType (CmmLit lit) = cmmLitType lit
cmmExprType (CmmLoad _ rep) = rep
cmmExprType (CmmReg reg) = cmmRegType reg
cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
cmmExprType (CmmRegOff reg _) = cmmRegType reg
cmmExprType (CmmStackSlot _ _) = bWord -- an address
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 :: CmmLit -> CmmType
cmmLitType (CmmInt _ width) = cmmBits width
cmmLitType (CmmFloat _ width) = cmmFloat width
cmmLitType (CmmLabel lbl) = cmmLabelType lbl
cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
cmmLitType (CmmLabelDiffOff {}) = bWord
cmmLitType (CmmBlock _) = bWord
cmmLitType (CmmHighStackMark) = bWord
cmmLitType :: DynFlags -> CmmLit -> CmmType
cmmLitType _ (CmmInt _ width) = cmmBits width
cmmLitType _ (CmmFloat _ width) = cmmFloat width
cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
cmmLitType dflags (CmmBlock _) = bWord dflags
cmmLitType dflags (CmmHighStackMark) = bWord dflags
cmmLabelType :: CLabel -> CmmType
cmmLabelType lbl | isGcPtrLabel lbl = gcWord
| otherwise = bWord
cmmLabelType :: DynFlags -> CLabel -> CmmType
cmmLabelType dflags lbl
| isGcPtrLabel lbl = gcWord
| otherwise = bWord dflags
cmmExprWidth :: CmmExpr -> Width
cmmExprWidth e = typeWidth (cmmExprType e)
cmmExprWidth :: DynFlags -> CmmExpr -> Width
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
--------
--- Negation for conditional branches
......@@ -164,9 +166,9 @@ instance Ord LocalReg where
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
cmmRegType :: CmmReg -> CmmType
cmmRegType (CmmLocal reg) = localRegType reg
cmmRegType (CmmGlobal reg) = globalRegType reg
cmmRegType :: DynFlags -> CmmReg -> CmmType
cmmRegType _ (CmmLocal reg) = localRegType reg
cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep
......@@ -412,12 +414,12 @@ nodeReg = CmmGlobal node
node :: GlobalReg
node = VanillaReg 1 VGcPtr
globalRegType :: GlobalReg -> CmmType
globalRegType (VanillaReg _ VGcPtr) = gcWord
globalRegType (VanillaReg _ VNonGcPtr) = bWord
globalRegType (FloatReg _) = cmmFloat W32
globalRegType (DoubleReg _) = cmmFloat W64
globalRegType (LongReg _) = cmmBits W64
globalRegType Hp = gcWord -- The initialiser for all
globalRegType :: DynFlags -> GlobalReg -> CmmType
globalRegType _ (VanillaReg _ VGcPtr) = gcWord
globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
globalRegType _ (FloatReg _) = cmmFloat W32
globalRegType _ (DoubleReg _) = cmmFloat W64
globalRegType _ (LongReg _) = cmmBits W64
globalRegType _ Hp = gcWord -- The initialiser for all
-- dynamically allocated closures
globalRegType _ = bWord
globalRegType dflags _ = bWord dflags
......@@ -120,7 +120,7 @@ cmmLayoutStack dflags procpoints entry_args
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
layout procpoints liveness entry entry_args
layout dflags procpoints liveness entry entry_args
rec_stackmaps rec_high_sp blocks
new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
......@@ -130,7 +130,8 @@ cmmLayoutStack dflags procpoints entry_args
layout :: BlockSet -- proc points
layout :: DynFlags
-> BlockSet -- proc points
-> BlockEnv CmmLive -- liveness
-> BlockId -- entry
-> ByteOff -- stack args on entry
......@@ -146,7 +147,7 @@ layout :: BlockSet -- proc points
, [CmmBlock] -- [out] new blocks
)
layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
layout dflags procpoints liveness entry entry_args final_stackmaps final_hwm blocks
= go blocks init_stackmap entry_args []
where
(updfr, cont_info) = collectContInfo blocks
......@@ -187,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- each of the successor blocks. See handleLastNode for
-- details.
(middle2, sp_off, last1, fixup_blocks, out)
<- handleLastNode procpoints liveness cont_info
<- handleLastNode dflags procpoints liveness cont_info
acc_stackmaps stack1 middle0 last0
-- pprTrace "layout(out)" (ppr out) $ return ()
......@@ -210,7 +211,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
-- beginning of a proc, and we don't modify Sp before the
-- check.
final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0
final_blocks = manifestSp dflags final_stackmaps stack0 sp0 sp_high entry0
middle_pre sp_off last1 fixup_blocks
acc_stackmaps' = mapUnion acc_stackmaps out
......@@ -317,7 +318,7 @@ getStackLoc (Young l) n stackmaps =
-- extra code that goes *after* the Sp adjustment.
handleLastNode
:: ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
:: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
-> BlockEnv StackMap -> StackMap
-> Block CmmNode O O
-> CmmNode O C
......@@ -329,7 +330,7 @@ handleLastNode
, BlockEnv StackMap -- stackmaps for the continuations
)
handleLastNode procpoints liveness cont_info stackmaps
handleLastNode dflags procpoints liveness cont_info stackmaps
stack0@StackMap { sm_sp = sp0 } middle last
= case last of
-- At each return / tail call,
......@@ -428,7 +429,7 @@ handleLastNode procpoints liveness cont_info stackmaps
| Just stack2 <- mapLookup l stackmaps
= do
let assigs = fixupStack stack0 stack2
(tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (b) if the successor is a proc point, save everything
......@@ -442,7 +443,7 @@ handleLastNode procpoints liveness cont_info stackmaps
setupStackFrame l liveness (sm_ret_off stack0)
cont_args stack0
--
(tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
return (l, tmp_lbl, stack2, block)
-- (c) otherwise, the current StackMap is the StackMap for
......@@ -456,14 +457,15 @@ handleLastNode procpoints liveness cont_info stackmaps
is_live (r,_) = r `elemRegSet` live
makeFixupBlock :: ByteOff -> Label -> StackMap -> [CmmNode O O] -> UniqSM (Label, [CmmBlock])
makeFixupBlock sp0 l stack assigs
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O]
-> UniqSM (Label, [CmmBlock])
makeFixupBlock dflags sp0 l stack assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
tmp_lbl <- liftM mkBlockId $ getUniqueM
let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl)
(maybeAddSpAdj sp_off (blockFromList assigs))
(maybeAddSpAdj dflags sp_off (blockFromList assigs))
(CmmBranch l)
return (tmp_lbl, [block])
......@@ -705,7 +707,8 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
-- middle_post, because the Sp adjustment intervenes.
--
manifestSp
:: BlockEnv StackMap -- StackMaps for other blocks
:: DynFlags
-> BlockEnv StackMap -- StackMaps for other blocks
-> StackMap -- StackMap for this block
-> ByteOff -- Sp on entry to the block
-> ByteOff -- SpHigh
......@@ -716,17 +719,17 @@ manifestSp
-> [CmmBlock] -- new blocks
-> [CmmBlock] -- final blocks with Sp manifest
manifestSp stackmaps stack0 sp0 sp_high
manifestSp dflags stackmaps stack0 sp0 sp_high
first middle_pre sp_off last fixup_blocks
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off)
adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off)
adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
final_middle = maybeAddSpAdj sp_off $
final_middle = maybeAddSpAdj dflags sp_off $
blockFromList $
map adj_pre_sp $
elimStackStores stack0 stackmaps area_off $
......@@ -747,10 +750,10 @@ getAreaOff stackmaps (Young l) =
Nothing -> pprPanic "getAreaOff" (ppr l)
maybeAddSpAdj :: ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj 0 block = block
maybeAddSpAdj sp_off block
= block `blockSnoc` CmmAssign spReg (cmmOffset (CmmReg spReg) sp_off)
maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj _ 0 block = block
maybeAddSpAdj dflags sp_off block
= block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
{-
......@@ -770,16 +773,16 @@ arguments.
to be Sp + Sp(L) - Sp(L')
-}
areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) =
cmmOffset (CmmReg spReg) (sp_old - area_off area - n)
areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr sp_hwm
areaToSp _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check]
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) =
cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
areaToSp _ _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr sp_hwm
areaToSp _ _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check]
[CmmMachOp (MO_Sub _)
[ CmmReg (CmmGlobal Sp)
, CmmLit (CmmInt 0 _)],
CmmReg (CmmGlobal SpLim)]) = zeroExpr
areaToSp _ _ _ other = other
areaToSp _ _ _ _ other = other
-- -----------------------------------------------------------------------------
-- Note [null stack check]
......@@ -910,8 +913,8 @@ lowerSafeForeignCall dflags block
= do
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
id <- newTemp bWord
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
id <- newTemp (bWord dflags)
new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
load_tso <- newTemp gcWord
load_stack <- newTemp gcWord
......@@ -935,7 +938,7 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) bWord
jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes wordWidth
......
......@@ -19,6 +19,7 @@ import BlockId
import FastString
import Outputable
import Constants
import DynFlags
import Data.Maybe
......@@ -31,15 +32,15 @@ import Data.Maybe
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
=> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops
=> DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops
cmmLintGraph :: CmmGraph -> Maybe SDoc
cmmLintGraph g = runCmmLint lintCmmGraph g
cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g
runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint l p =
case unCL (l p) of
runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint dflags l p =
case unCL (l p) dflags of
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
nest 2 err,
ptext $ sLit ("Program was:"),
......@@ -85,23 +86,27 @@ lintCmmExpr (CmmLoad expr rep) = do
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
dflags <- getDynFlags
tys <- mapM lintCmmExpr args
if map (typeWidth . cmmExprType) args == machOpArgReps op
if map (typeWidth . cmmExprType dflags) args == machOpArgReps op
then cmmCheckMachOp op args tys
else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op)
else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps op)
lintCmmExpr (CmmRegOff reg offset)
= lintCmmExpr (CmmMachOp (MO_Add rep)
= do dflags <- getDynFlags
let rep = typeWidth (cmmRegType dflags reg)
lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
where rep = typeWidth (cmmRegType reg)
lintCmmExpr expr =
return (cmmExprType expr)
do dflags <- getDynFlags
return (cmmExprType dflags 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
= return (machOpResultType op tys)
= do dflags <- getDynFlags
return (machOpResultType dflags op tys)
isOffsetOp :: MachOp -> Bool
isOffsetOp (MO_Add _) = True
......@@ -131,8 +136,9 @@ lintCmmMiddle node = case node of
CmmComment _ -> return ()
CmmAssign reg expr -> do
dflags <- getDynFlags
erep <- lintCmmExpr expr
let reg_ty = cmmRegType reg
let reg_ty = cmmRegType dflags reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
......@@ -157,9 +163,10 @@ lintCmmLast labels node = case node of
checkCond e
CmmSwitch e branches -> do
dflags <- getDynFlags
mapM_ checkTarget $ catMaybes branches
erep <- lintCmmExpr e
if (erep `cmmEqType_ignoring_ptrhood` bWord)
if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
ppr e <> text " :: " <> ppr erep)
......@@ -195,20 +202,24 @@ checkCond expr
-- just a basic error monad:
newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
instance Monad CmmLint where
CmmLint m >>= k = CmmLint $ case m of
CmmLint m >>= k = CmmLint $ \dflags ->
case m dflags of
Left e -> Left e
Right a -> unCL (k a)
return a = CmmLint (Right a)
Right a -> unCL (k a) dflags
return a = CmmLint (\_ -> Right a)
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (Left msg)
cmmLintErr msg = CmmLint (\_ -> Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
addLintInfo info thing = CmmLint $
case unCL thing of
addLintInfo info thing = CmmLint $ \dflags ->
case unCL thing dflags of
Left err -> Left (hang info 2 err)
Right a -> Right a
......
......@@ -25,6 +25,7 @@ where
import CmmType
import Outputable
import DynFlags
-----------------------------------------------------------------------------
-- MachOp
......@@ -283,8 +284,8 @@ maybeInvertComparison op
{- |
Returns the MachRep of the result of a MachOp.
-}
machOpResultType :: MachOp -> [CmmType] -> CmmType
machOpResultType mop tys =
machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
machOpResultType dflags mop tys =
case mop of
MO_Add {} -> ty1 -- Preserve GC-ptr-hood
MO_Sub {} -> ty1 -- of first arg
......@@ -297,29 +298,29 @@ machOpResultType mop tys =
MO_U_Quot r -> cmmBits r
MO_U_Rem r -> cmmBits r
MO_Eq {} -> comparisonResultRep
MO_Ne {} -> comparisonResultRep
MO_S_Ge {} -> comparisonResultRep
MO_S_Le {} -> comparisonResultRep
MO_S_Gt {} -> comparisonResultRep
MO_S_Lt {} -> comparisonResultRep
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_U_Ge {} -> comparisonResultRep
MO_U_Le {} -> comparisonResultRep
MO_U_Gt {} -> comparisonResultRep
MO_U_Lt {} -> comparisonResultRep
MO_U_Ge {} -> comparisonResultRep dflags
MO_U_Le {} -> comparisonResultRep dflags
MO_U_Gt {} -> comparisonResultRep dflags
MO_U_Lt {} -> comparisonResultRep dflags
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
MO_F_Ne {} -> comparisonResultRep
MO_F_Ge {} -> comparisonResultRep
MO_F_Le {} -> comparisonResultRep
MO_F_Gt {} -> comparisonResultRep
MO_F_Lt {} -> comparisonResultRep
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_And {} -> ty1 -- Used for pointer masking
MO_Or {} -> ty1
......@@ -337,7 +338,7 @@ machOpResultType mop tys =
where
(ty1:_) = tys
comparisonResultRep :: CmmType
comparisonResultRep :: DynFlags -> CmmType
comparisonResultRep = bWord -- is it?
......
......@@ -522,7 +522,7 @@ expr0 :: { ExtFCode CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
: {- empty -} { bWord }
: {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags }
| '::' type { $2 }
maybe_actuals :: { [ExtFCode HintedCmmActual] }
......@@ -630,8 +630,9 @@ mkString s = CmmString (map (fromIntegral.ord) s)
-- the op.
mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
mkMachOp fn args = do
dflags <- getDynFlags
arg_exprs <- sequence args
return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs)
return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
......@@ -658,12 +659,12 @@ exprOp name args_code = do
exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
exprMacros dflags = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ),
( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr x) ),
( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),
( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
......@@ -868,7 +869,7 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
-- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
_ ->
let expr' = adjCallTarget platform convention expr args in
let expr' = adjCallTarget dflags convention expr args in
case safety of
CmmUnsafe ->
code (emitForeignCall' PlayRisky results
......@@ -880,13 +881,14 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
code (emitForeignCall' PlayInterruptible results
(CmmCallee expr' convention) args vols NoC_SRT ret)
adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
-> CmmExpr
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args
adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
| platformOS (targetPlatform dflags) == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e)))
where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType dflags e)))
-- c.f. CgForeignCall.emitForeignCall
adjCallTarget _ _ expr _
= expr
......@@ -917,14 +919,15 @@ primCall results_code name args_code vols safety
doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code
= do addr <- addr_code
= do dflags <- getDynFlags
addr <- addr_code
val <- val_code
-- if the specified store type does not match the type of the expr
-- on the rhs, then we insert a coercion that will cause the type
-- 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 val)
let val_width = typeWidth (cmmExprType dflags val)
rep_width = typeWidth rep
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
......@@ -941,7 +944,7 @@ emitRetUT args = do
-- or regs that we assign to, so better use
-- simultaneous assignments here (#3546)
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) (bWord dflags))) (Just live)
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
......
......@@ -183,7 +183,7 @@ dumpGraph dflags flag name g = do
when (dopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name g
where
do_lint g = case cmmLintGraph g of
do_lint g = case cmmLintGraph dflags g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
}
......
......@@ -20,6 +20,7 @@ import CmmUtils
import CmmOpt
import StgCmmUtils
import DynFlags
import UniqSupply
import Platform
import UniqFM
......@@ -35,8 +36,9 @@ import Prelude hiding (succ, zip)
----------------------------------------------------------------
--- Main function
rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph
rewriteAssignments platform g = do
rewriteAssignments :: DynFlags -> CmmGraph -> UniqSM CmmGraph
rewriteAssignments dflags g = do
let platform = targetPlatform dflags
-- Because we need to act on forwards and backwards information, we
-- first perform usage analysis and bake this information into the
-- graph (backwards transform), and then do a forwards transform
......@@ -44,7 +46,7 @@ rewriteAssignments platform g = do
g' <- annotateUsage g
g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
analRewFwd assignmentLattice
(assignmentTransfer platform)
(assignmentTransfer dflags)
(assignmentRewrite `thenFwdRw` machOpFoldRewrite platform)
return (modifyGraph eraseRegUsage g'')
......@@ -309,7 +311,7 @@ invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
-- optimize; we need an algorithmic change to prevent us from having to
-- traverse the /entire/ map continually.
middleAssignment :: Platform -> WithRegUsage CmmNode O O -> AssignmentMap
middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap
-> AssignmentMap
-- Algorithm for annotated assignments:
......@@ -349,10 +351,10 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign
-- 1. Delete any sinking assignments that were used by this instruction
-- 2. Look for all assignments that load from memory locations that
-- were clobbered by this store and invalidate them.
middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign
</