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

Add "Unregisterised" as a field in the settings file

To explicitly choose whether you want an unregisterised build you now
need to use the "--enable-unregisterised"/"--disable-unregisterised"
configure flags.
parent e6ef5ab6
......@@ -20,8 +20,9 @@ import PprCmm ()
import Constants
import qualified Data.List as L
import StaticFlags (opt_Unregisterised)
import DynFlags
import Outputable
import Platform
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
......@@ -37,22 +38,22 @@ instance Outputable ParamLocation where
-- | JD: For the new stack story, I want arguments passed on the stack to manifest as
-- positive offsets in a CallArea, not negative offsets from the stack pointer.
-- Also, I want byte offsets, not word offsets.
assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] ->
assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
[(a, ParamLocation)]
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
assignArgumentsPos conv arg_ty reps = assignments
assignArgumentsPos dflags conv arg_ty reps = assignments
where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode
(_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers
(_, GC) -> allRegs
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
(_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
......@@ -110,25 +111,34 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Vanilla_REG
floatRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Float_REG
doubleRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Double_REG
longRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Long_REG
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
vanillaRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Vanilla_REG
floatRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Float_REG
doubleRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Double_REG
longRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Long_REG
--
getRegsWithoutNode, getRegsWithNode :: AvailRegs
getRegsWithoutNode =
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
getRegsWithoutNode dflags =
(filter (\r -> r VGcPtr /= node) intRegs,
map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
getRegsWithNode =
(intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
map FloatReg (floatRegNos dflags),
map DoubleReg (doubleRegNos dflags),
map LongReg (longRegNos dflags))
where intRegs = map VanillaReg (vanillaRegNos dflags)
getRegsWithNode dflags =
(intRegs,
map FloatReg (floatRegNos dflags),
map DoubleReg (doubleRegNos dflags),
map LongReg (longRegNos dflags))
where intRegs = map VanillaReg (vanillaRegNos dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg]
......
......@@ -929,7 +929,7 @@ lowerSafeForeignCall dflags block
caller_load <*>
loadThreadState dflags load_tso load_stack
(ret_args, regs, copyout) = copyOutOflow NativeReturn Jump (Young succ)
(ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
updfr (0, [])
......
......@@ -24,6 +24,7 @@ import CmmCallConv (assignArgumentsPos, ParamLocation(..))
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags
import FastString
import ForeignCall
import Outputable
......@@ -172,31 +173,35 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r
---------- Control transfer
mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkJump e actuals updfr_off =
lastWithArgs Jump Old NativeNodeCall actuals updfr_off $
mkJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkJump dflags e actuals updfr_off =
lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
toCall e Nothing updfr_off 0
mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkDirectJump e actuals updfr_off =
lastWithArgs Jump Old NativeDirectCall actuals updfr_off $
mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkDirectJump dflags e actuals updfr_off =
lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
toCall e Nothing updfr_off 0
mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkJumpGC e actuals updfr_off =
lastWithArgs Jump Old GC actuals updfr_off $
mkJumpGC :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkJumpGC dflags e actuals updfr_off =
lastWithArgs dflags Jump Old GC actuals updfr_off $
toCall e Nothing updfr_off 0
mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
mkForeignJump :: DynFlags
-> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkForeignJump conv e actuals updfr_off =
mkForeignJumpExtra conv e actuals updfr_off noExtraStack
mkForeignJump dflags conv e actuals updfr_off =
mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
mkForeignJumpExtra :: Convention -> CmmExpr -> [CmmActual]
mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
-> CmmAGraph
mkForeignJumpExtra conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack Jump Old conv actuals updfr_off extra_stack $
mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
......@@ -205,45 +210,47 @@ mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturn e actuals updfr_off =
lastWithArgs Ret Old NativeReturn actuals updfr_off $
mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple actuals updfr_off =
mkReturn e actuals updfr_off
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
mkFinalCall :: DynFlags
-> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkFinalCall f _ actuals updfr_off =
lastWithArgs Call Old NativeDirectCall actuals updfr_off $
mkFinalCall dflags f _ actuals updfr_off =
lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
mkCallReturnsTo :: CmmExpr -> Convention -> [CmmActual]
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)])
-> CmmAGraph
mkCallReturnsTo f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack Call (Young ret_lbl) callConv actuals
mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
mkJumpReturnsTo :: CmmExpr -> Convention -> [CmmActual]
mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> CmmAGraph
mkJumpReturnsTo f callConv actuals ret_lbl ret_off updfr_off = do
lastWithArgs JumpRet (Young ret_lbl) callConv actuals updfr_off $
mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
......@@ -269,25 +276,26 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- the variables in their spill slots.
-- Therefore, for copying arguments and results, we provide different
-- functions to pass the arguments in an overflow area and to pass them in spill slots.
copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal]
-> (Int, CmmAGraph)
copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn oneCopyOflowI conv area formals
copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
(ByteOff, [CmmNode O O])
type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
type CopyIn = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: CopyIn
copyIn oflow conv area formals =
copyIn dflags oflow conv area formals =
foldr ci (init_offset, []) args'
where ci (reg, RegisterParam r) (n, ms) =
(n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
init_offset = widthInBytes wordWidth -- infotable
args = assignArgumentsPos conv localRegType formals
args = assignArgumentsPos dflags conv localRegType formals
args' = foldl adjust [] args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst
......@@ -303,7 +311,7 @@ oneCopyOflowI area (reg, off) (n, ms) =
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
-> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
-> (Int, [GlobalReg], CmmAGraph)
......@@ -317,7 +325,7 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-- the info table for return and adjust the offsets of the other
-- parameters. If this is a call instruction, we adjust the offsets
-- of the other parameters.
copyOutOflow conv transfer area actuals updfr_off
copyOutOflow dflags conv transfer area actuals updfr_off
(extra_stack_off, extra_stack_stuff)
= foldr co (init_offset, [], mkNop) (args' ++ stack_params)
where
......@@ -347,7 +355,7 @@ copyOutOflow conv transfer area actuals updfr_off
arg_offset = init_offset + extra_stack_off
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
args = assignArgumentsPos conv cmmExprType actuals
args = assignArgumentsPos dflags conv cmmExprType actuals
args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
......@@ -355,26 +363,27 @@ copyOutOflow conv transfer area actuals updfr_off
mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry conv formals = copyInOflow conv Old formals
mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual]
lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack transfer area conv actuals
lastWithArgs dflags transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack dflags transfer area conv actuals
updfr_off noExtraStack last
lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual]
lastWithArgsAndExtraStack :: DynFlags
-> Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack transfer area conv actuals updfr_off
lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
extra_stack last =
copies <*> last outArgs regs
where
(outArgs, regs, copies) = copyOutOflow conv transfer area actuals
(outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
updfr_off extra_stack
......
......@@ -43,10 +43,10 @@ import Id
import Name
import Util
import DynFlags
import StaticFlags
import Module
import FastString
import Outputable
import Platform
import Data.Bits
-------------------------------------------------------------------------
......@@ -255,16 +255,19 @@ getSequelAmode
-- registers. This is used for calling special RTS functions and PrimOps
-- which expect their arguments to always be in the same registers.
assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
:: [(CgRep,a)] -- Arg or result values to assign
-> ([(a, GlobalReg)], -- Register assignment in same order
-- for *initial segment of* input list
-- (but reversed; doesn't matter)
-- VoidRep args do not appear here
[(CgRep,a)]) -- Leftover arg or result values
type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign
-> ([(a, GlobalReg)], -- Register assignment in same order
-- for *initial segment of* input list
-- (but reversed; doesn't matter)
-- VoidRep args do not appear here
[(CgRep,a)]) -- Leftover arg or result values
assignCallRegs args
= assign_regs args (mkRegTbl [node])
assignCallRegs :: DynFlags -> AssignRegs a
assignPrimOpCallRegs :: AssignRegs a
assignReturnRegs :: DynFlags -> AssignRegs a
assignCallRegs dflags args
= assign_regs args (mkRegTbl dflags [node])
-- The entry convention for a function closure
-- never uses Node for argument passing; instead
-- Node points to the function closure itself
......@@ -273,7 +276,7 @@ assignPrimOpCallRegs args
= assign_regs args (mkRegTbl_allRegs [])
-- For primops, *all* arguments must be passed in registers
assignReturnRegs args
assignReturnRegs dflags args
-- when we have a single non-void component to return, use the normal
-- unpointed return convention. This make various things simpler: it
-- means we can assume a consistent convention for IO, which is useful
......@@ -285,7 +288,7 @@ assignReturnRegs args
| [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
= ([(arg, r)], [])
| otherwise
= assign_regs args (mkRegTbl [])
= assign_regs args (mkRegTbl dflags [])
-- For returning unboxed tuples etc,
-- we use all regs
where
......@@ -327,24 +330,28 @@ assign_reg _ _ = Nothing
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.
useVanillaRegs :: Int
useVanillaRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Vanilla_REG
useFloatRegs :: Int
useFloatRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Float_REG
useDoubleRegs :: Int
useDoubleRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Double_REG
useLongRegs :: Int
useLongRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Long_REG
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos = regList useVanillaRegs
floatRegNos = regList useFloatRegs
doubleRegNos = regList useDoubleRegs
longRegNos = regList useLongRegs
useVanillaRegs :: DynFlags -> Int
useVanillaRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Vanilla_REG
useFloatRegs :: DynFlags -> Int
useFloatRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Float_REG
useDoubleRegs :: DynFlags -> Int
useDoubleRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Double_REG
useLongRegs :: DynFlags -> Int
useLongRegs dflags
| platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Long_REG
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
vanillaRegNos dflags = regList $ useVanillaRegs dflags
floatRegNos dflags = regList $ useFloatRegs dflags
doubleRegNos dflags = regList $ useDoubleRegs dflags
longRegNos dflags = regList $ useLongRegs dflags
allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
......@@ -361,9 +368,12 @@ type AvailRegs = ( [Int] -- available vanilla regs.
, [Int] -- longs (int64 and word64)
)
mkRegTbl :: [GlobalReg] -> AvailRegs
mkRegTbl regs_in_use
= mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
mkRegTbl dflags regs_in_use
= mkRegTbl' regs_in_use (vanillaRegNos dflags)
(floatRegNos dflags)
(doubleRegNos dflags)
(longRegNos dflags)
mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
mkRegTbl_allRegs regs_in_use
......
......@@ -273,10 +273,12 @@ Node points to closure is available. -- HWL
\begin{code}
closureCodeBody _binder_info cl_info cc args body
= ASSERT( length args > 0 )
do { -- Get the current virtual Sp (it might not be zero,
do {
dflags <- getDynFlags
-- Get the current virtual Sp (it might not be zero,
-- eg. if we're compiling a let-no-escape).
vSp <- getVirtSp
; let (reg_args, other_args) = assignCallRegs (addIdReps args)
; vSp <- getVirtSp
; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
(sp_top, stk_args) = mkVirtStkOffsets vSp other_args
-- Allocate the global ticky counter
......
......@@ -271,11 +271,13 @@ bindUnboxedTupleComponents
bindUnboxedTupleComponents args
= do {
vsp <- getVirtSp
dflags <- getDynFlags
; vsp <- getVirtSp
; rsp <- getRealSp
-- Assign as many components as possible to registers
; let (reg_args, stk_args) = assignReturnRegs (addIdReps args)
; let (reg_args, stk_args) = assignReturnRegs dflags (addIdReps args)
-- Separate the rest of the args into pointers and non-pointers
(ptr_args, nptr_args) = separateByPtrFollowness stk_args
......
......@@ -255,7 +255,7 @@ directCall sp lbl args extra_args live_node assts = do
dflags <- getDynFlags
let
-- First chunk of args go in registers
(reg_arg_amodes, stk_args) = assignCallRegs args
(reg_arg_amodes, stk_args) = assignCallRegs dflags args
-- Any "extra" arguments are placed in frames on the
-- stack after the other arguments.
......@@ -354,7 +354,8 @@ pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing
pushUnboxedTuple sp []
= return (sp, noStmts, [])
pushUnboxedTuple sp amodes
= do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes
= do { dflags <- getDynFlags
; let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes
live_regs = map snd reg_arg_amodes
-- separate the rest of the args into pointers and non-pointers
......
......@@ -470,7 +470,8 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
let slow_lbl = closureSlowEntryLabel cl_info
fast_lbl = closureLocalEntryLabel dflags cl_info
-- mkDirectJump does not clobber `Node' containing function closure
jump = mkDirectJump (mkLblExpr fast_lbl)
jump = mkDirectJump dflags
(mkLblExpr fast_lbl)
(map (CmmReg . CmmLocal) arg_regs)
initUpdFrameOff
emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
......@@ -680,7 +681,7 @@ link_caf _is_upd = do
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
(let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
mkJump target [] updfr)
mkJump dflags target [] updfr)
; return hp_rel }
......
......@@ -674,7 +674,7 @@ emitEnter fun = do
-- test, just generating an enter.
Return _ -> do
{ let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg
; emit $ mkForeignJump NativeNodeCall entry
; emit $ mkForeignJump dflags NativeNodeCall entry
[cmmUntag fun] updfr_off
; return AssignedDirectly
}
......@@ -706,11 +706,11 @@ emitEnter fun = do
--
AssignTo res_regs _ -> do
{ lret <- newLabelC
; let (off, copyin) = copyInOflow NativeReturn (Young lret) res_regs
; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs
; lcall <- newLabelC
; updfr_off <- getUpdFrameOff
; let area = Young lret
; let (outArgs, regs, copyout) = copyOutOflow NativeNodeCall Call area
; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
[fun] updfr_off (0,[])
-- refer to fun via nodeReg after the copyout, to avoid having
-- both live simultaneously; this sometimes enables fun to be
......
......@@ -214,10 +214,11 @@ emitForeignCall safety results target args _ret
return AssignedDirectly
| otherwise = do
dflags <- getDynFlags
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
k <- newLabelC
let (off, copyout) = copyInOflow NativeReturn (Young k) results
let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
-- see Note [safe foreign call convention]
emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
......
......@@ -348,7 +348,8 @@ entryHeapCheck :: ClosureInfo
-> FCode ()
entryHeapCheck cl_info offset nodeSet arity args code
= do let is_thunk = arity == 0
= do dflags <- getDynFlags
let is_thunk = arity == 0
is_fastf = case closureFunInfo cl_info of
Just (_, ArgGen _) -> False
_otherwise -> True
......@@ -365,9 +366,9 @@ entryHeapCheck cl_info offset nodeSet arity args code
Function (slow): Set R1 = node, call generic_gc -}
gc_call upd = setN <*> gc_lbl upd
gc_lbl upd
| is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
| is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
| otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
| is_thunk = mkDirectJump dflags (CmmReg $ CmmGlobal GCEnter1) [] sp
| is_fastf = mkDirectJump dflags (CmmReg $ CmmGlobal GCFun) [] sp
| otherwise = mkForeignJump dflags Slow (CmmReg $ CmmGlobal GCFun) args' upd
where sp = max offset upd
{- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
- This is since the ncg inserts spills before the stack/heap check.
......@@ -447,8 +448,9 @@ altHeapCheck regs code
= case cannedGCEntryPoint regs of
Nothing -> genericGC code
Just gc -> do
dflags <- getDynFlags
lret <- newLabelC
let (off, copyin) = copyInOflow NativeReturn (Young lret) regs
let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
lcont <- newLabelC
emitOutOfLine lret (copyin <*> mkBranch lcont)
emitLabel lcont
......@@ -464,15 +466,16 @@ cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
-> FCode a
-> FCode a
cannedGCReturnsTo cont_on_stack gc regs lret off code
= do updfr_sz <- getUpdFrameOff
heapCheck False (gc_call gc updfr_sz) code
= do dflags <- getDynFlags
updfr_sz <- getUpdFrameOff
heapCheck False (gc_call dflags gc updfr_sz) code
where
reg_exprs = map (CmmReg . CmmLocal) regs
-- Note [stg_gc arguments]
gc_call label sp
| cont_on_stack = mkJumpReturnsTo label GC reg_exprs lret off sp
| otherwise = mkCallReturnsTo label GC reg_exprs lret off sp (0,[])
gc_call dflags label sp
| cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
| otherwise = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
genericGC :: FCode a -> FCode a
genericGC code
......
......@@ -78,12 +78,13 @@ import FastString
--
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn results
= do { sequel <- getSequel;
= do { dflags <- getDynFlags
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; case sequel of
Return _ ->
do { adjustHpBackwards
; emit (mkReturnSimple results updfr_off) }
; emit (mkReturnSimple dflags results updfr_off) }
AssignTo regs adjust ->
do { if adjust then adjustHpBackwards else return ()
; emitMultiAssign regs results }
......@@ -109,18 +110,19 @@ emitCallWithExtraStack
:: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
emitCallWithExtraStack (callConv, retConv) fun args extra_stack
= do { adjustHpBackwards
= do { dflags <- getDynFlags
; adjustHpBackwards