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 () ...@@ -20,8 +20,9 @@ import PprCmm ()
import Constants import Constants
import qualified Data.List as L import qualified Data.List as L
import StaticFlags (opt_Unregisterised) import DynFlags
import Outputable import Outputable
import Platform
-- Calculate the 'GlobalReg' or stack locations for function call -- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention. -- parameters as used by the Cmm calling convention.
...@@ -37,22 +38,22 @@ instance Outputable ParamLocation where ...@@ -37,22 +38,22 @@ instance Outputable ParamLocation where
-- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- | 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. -- positive offsets in a CallArea, not negative offsets from the stack pointer.
-- Also, I want byte offsets, not word offsets. -- Also, I want byte offsets, not word offsets.
assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] -> assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
[(a, ParamLocation)] [(a, ParamLocation)]
-- Given a list of arguments, and a function that tells their types, -- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed -- 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 where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = case (reps, conv) of regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode (_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode (_, NativeDirectCall) -> getRegsWithoutNode dflags
([_], NativeReturn) -> allRegs ([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode (_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers -- GC calling convention *must* put values in registers
(_, GC) -> allRegs (_, GC) -> allRegs
(_, PrimOpCall) -> allRegs (_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs ([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode (_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs (_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers, -- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers -- then switch to the stack when we first run out of registers
...@@ -110,25 +111,34 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. ...@@ -110,25 +111,34 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those -- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers. -- that are guaranteed to map to machine registers.
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
vanillaRegNos | opt_Unregisterised = [] vanillaRegNos dflags
| otherwise = regList mAX_Real_Vanilla_REG | platformUnregisterised (targetPlatform dflags) = []
floatRegNos | opt_Unregisterised = [] | otherwise = regList mAX_Real_Vanilla_REG
| otherwise = regList mAX_Real_Float_REG floatRegNos dflags
doubleRegNos | opt_Unregisterised = [] | platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Double_REG | otherwise = regList mAX_Real_Float_REG
longRegNos | opt_Unregisterised = [] doubleRegNos dflags
| otherwise = regList mAX_Real_Long_REG | platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Double_REG
longRegNos dflags
| platformUnregisterised (targetPlatform dflags) = []
| otherwise = regList mAX_Real_Long_REG
-- --
getRegsWithoutNode, getRegsWithNode :: AvailRegs getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
getRegsWithoutNode = getRegsWithoutNode dflags =
(filter (\r -> r VGcPtr /= node) intRegs, (filter (\r -> r VGcPtr /= node) intRegs,
map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos) map FloatReg (floatRegNos dflags),
where intRegs = map VanillaReg vanillaRegNos map DoubleReg (doubleRegNos dflags),
getRegsWithNode = map LongReg (longRegNos dflags))
(intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos) where intRegs = map VanillaReg (vanillaRegNos dflags)
where intRegs = map VanillaReg vanillaRegNos 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] allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg] allVanillaRegs :: [VGcPtr -> GlobalReg]
......
...@@ -929,7 +929,7 @@ lowerSafeForeignCall dflags block ...@@ -929,7 +929,7 @@ lowerSafeForeignCall dflags block
caller_load <*> caller_load <*>
loadThreadState dflags load_tso load_stack 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) (map (CmmReg . CmmLocal) res)
updfr (0, []) updfr (0, [])
......
This diff is collapsed.
...@@ -43,10 +43,10 @@ import Id ...@@ -43,10 +43,10 @@ import Id
import Name import Name
import Util import Util
import DynFlags import DynFlags
import StaticFlags
import Module import Module
import FastString import FastString
import Outputable import Outputable
import Platform
import Data.Bits import Data.Bits
------------------------------------------------------------------------- -------------------------------------------------------------------------
...@@ -255,16 +255,19 @@ getSequelAmode ...@@ -255,16 +255,19 @@ getSequelAmode
-- registers. This is used for calling special RTS functions and PrimOps -- registers. This is used for calling special RTS functions and PrimOps
-- which expect their arguments to always be in the same registers. -- which expect their arguments to always be in the same registers.
assignCallRegs, assignPrimOpCallRegs, assignReturnRegs type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign
:: [(CgRep,a)] -- Arg or result values to assign -> ([(a, GlobalReg)], -- Register assignment in same order
-> ([(a, GlobalReg)], -- Register assignment in same order -- for *initial segment of* input list
-- for *initial segment of* input list -- (but reversed; doesn't matter)
-- (but reversed; doesn't matter) -- VoidRep args do not appear here
-- VoidRep args do not appear here [(CgRep,a)]) -- Leftover arg or result values
[(CgRep,a)]) -- Leftover arg or result values
assignCallRegs args assignCallRegs :: DynFlags -> AssignRegs a
= assign_regs args (mkRegTbl [node]) assignPrimOpCallRegs :: AssignRegs a
assignReturnRegs :: DynFlags -> AssignRegs a
assignCallRegs dflags args
= assign_regs args (mkRegTbl dflags [node])
-- The entry convention for a function closure -- The entry convention for a function closure
-- never uses Node for argument passing; instead -- never uses Node for argument passing; instead
-- Node points to the function closure itself -- Node points to the function closure itself
...@@ -273,7 +276,7 @@ assignPrimOpCallRegs args ...@@ -273,7 +276,7 @@ assignPrimOpCallRegs args
= assign_regs args (mkRegTbl_allRegs []) = assign_regs args (mkRegTbl_allRegs [])
-- For primops, *all* arguments must be passed in registers -- 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 -- when we have a single non-void component to return, use the normal
-- unpointed return convention. This make various things simpler: it -- unpointed return convention. This make various things simpler: it
-- means we can assume a consistent convention for IO, which is useful -- means we can assume a consistent convention for IO, which is useful
...@@ -285,7 +288,7 @@ assignReturnRegs args ...@@ -285,7 +288,7 @@ assignReturnRegs args
| [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
= ([(arg, r)], []) = ([(arg, r)], [])
| otherwise | otherwise
= assign_regs args (mkRegTbl []) = assign_regs args (mkRegTbl dflags [])
-- For returning unboxed tuples etc, -- For returning unboxed tuples etc,
-- we use all regs -- we use all regs
where where
...@@ -327,24 +330,28 @@ assign_reg _ _ = Nothing ...@@ -327,24 +330,28 @@ assign_reg _ _ = Nothing
-- We take these register supplies from the *real* registers, i.e. those -- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers. -- that are guaranteed to map to machine registers.
useVanillaRegs :: Int useVanillaRegs :: DynFlags -> Int
useVanillaRegs | opt_Unregisterised = 0 useVanillaRegs dflags
| otherwise = mAX_Real_Vanilla_REG | platformUnregisterised (targetPlatform dflags) = 0
useFloatRegs :: Int | otherwise = mAX_Real_Vanilla_REG
useFloatRegs | opt_Unregisterised = 0 useFloatRegs :: DynFlags -> Int
| otherwise = mAX_Real_Float_REG useFloatRegs dflags
useDoubleRegs :: Int | platformUnregisterised (targetPlatform dflags) = 0
useDoubleRegs | opt_Unregisterised = 0 | otherwise = mAX_Real_Float_REG
| otherwise = mAX_Real_Double_REG useDoubleRegs :: DynFlags -> Int
useLongRegs :: Int useDoubleRegs dflags
useLongRegs | opt_Unregisterised = 0 | platformUnregisterised (targetPlatform dflags) = 0
| otherwise = mAX_Real_Long_REG | otherwise = mAX_Real_Double_REG
useLongRegs :: DynFlags -> Int
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] useLongRegs dflags
vanillaRegNos = regList useVanillaRegs | platformUnregisterised (targetPlatform dflags) = 0
floatRegNos = regList useFloatRegs | otherwise = mAX_Real_Long_REG
doubleRegNos = regList useDoubleRegs
longRegNos = regList useLongRegs 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, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG allVanillaRegNos = regList mAX_Vanilla_REG
...@@ -361,9 +368,12 @@ type AvailRegs = ( [Int] -- available vanilla regs. ...@@ -361,9 +368,12 @@ type AvailRegs = ( [Int] -- available vanilla regs.
, [Int] -- longs (int64 and word64) , [Int] -- longs (int64 and word64)
) )
mkRegTbl :: [GlobalReg] -> AvailRegs mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
mkRegTbl regs_in_use mkRegTbl dflags regs_in_use
= mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos = mkRegTbl' regs_in_use (vanillaRegNos dflags)
(floatRegNos dflags)
(doubleRegNos dflags)
(longRegNos dflags)
mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
mkRegTbl_allRegs regs_in_use mkRegTbl_allRegs regs_in_use
......
...@@ -273,10 +273,12 @@ Node points to closure is available. -- HWL ...@@ -273,10 +273,12 @@ Node points to closure is available. -- HWL
\begin{code} \begin{code}
closureCodeBody _binder_info cl_info cc args body closureCodeBody _binder_info cl_info cc args body
= ASSERT( length args > 0 ) = 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). -- eg. if we're compiling a let-no-escape).
vSp <- getVirtSp ; vSp <- getVirtSp
; let (reg_args, other_args) = assignCallRegs (addIdReps args) ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
(sp_top, stk_args) = mkVirtStkOffsets vSp other_args (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
-- Allocate the global ticky counter -- Allocate the global ticky counter
......
...@@ -271,11 +271,13 @@ bindUnboxedTupleComponents ...@@ -271,11 +271,13 @@ bindUnboxedTupleComponents
bindUnboxedTupleComponents args bindUnboxedTupleComponents args
= do { = do {
vsp <- getVirtSp dflags <- getDynFlags
; vsp <- getVirtSp
; rsp <- getRealSp ; rsp <- getRealSp
-- Assign as many components as possible to registers -- 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 -- Separate the rest of the args into pointers and non-pointers
(ptr_args, nptr_args) = separateByPtrFollowness stk_args (ptr_args, nptr_args) = separateByPtrFollowness stk_args
......
...@@ -255,7 +255,7 @@ directCall sp lbl args extra_args live_node assts = do ...@@ -255,7 +255,7 @@ directCall sp lbl args extra_args live_node assts = do
dflags <- getDynFlags dflags <- getDynFlags
let let
-- First chunk of args go in registers -- 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 -- Any "extra" arguments are placed in frames on the
-- stack after the other arguments. -- stack after the other arguments.
...@@ -354,7 +354,8 @@ pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing ...@@ -354,7 +354,8 @@ pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing
pushUnboxedTuple sp [] pushUnboxedTuple sp []
= return (sp, noStmts, []) = return (sp, noStmts, [])
pushUnboxedTuple sp amodes 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 live_regs = map snd reg_arg_amodes
-- separate the rest of the args into pointers and non-pointers -- 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' ...@@ -470,7 +470,8 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
let slow_lbl = closureSlowEntryLabel cl_info let slow_lbl = closureSlowEntryLabel cl_info
fast_lbl = closureLocalEntryLabel dflags cl_info fast_lbl = closureLocalEntryLabel dflags cl_info
-- mkDirectJump does not clobber `Node' containing function closure -- mkDirectJump does not clobber `Node' containing function closure
jump = mkDirectJump (mkLblExpr fast_lbl) jump = mkDirectJump dflags
(mkLblExpr fast_lbl)
(map (CmmReg . CmmLocal) arg_regs) (map (CmmReg . CmmLocal) arg_regs)
initUpdFrameOff initUpdFrameOff
emitProcWithConvention Slow Nothing slow_lbl arg_regs jump emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
...@@ -680,7 +681,7 @@ link_caf _is_upd = do ...@@ -680,7 +681,7 @@ link_caf _is_upd = do
-- assuming lots of things, like the stack pointer hasn't -- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF. -- moved since we entered the CAF.
(let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
mkJump target [] updfr) mkJump dflags target [] updfr)
; return hp_rel } ; return hp_rel }
......
...@@ -674,7 +674,7 @@ emitEnter fun = do ...@@ -674,7 +674,7 @@ emitEnter fun = do
-- test, just generating an enter. -- test, just generating an enter.
Return _ -> do Return _ -> do
{ let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg { let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg
; emit $ mkForeignJump NativeNodeCall entry ; emit $ mkForeignJump dflags NativeNodeCall entry
[cmmUntag fun] updfr_off [cmmUntag fun] updfr_off
; return AssignedDirectly ; return AssignedDirectly
} }
...@@ -706,11 +706,11 @@ emitEnter fun = do ...@@ -706,11 +706,11 @@ emitEnter fun = do
-- --
AssignTo res_regs _ -> do AssignTo res_regs _ -> do
{ lret <- newLabelC { lret <- newLabelC
; let (off, copyin) = copyInOflow NativeReturn (Young lret) res_regs ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs
; lcall <- newLabelC ; lcall <- newLabelC
; updfr_off <- getUpdFrameOff ; updfr_off <- getUpdFrameOff
; let area = Young lret ; 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,[]) [fun] updfr_off (0,[])
-- refer to fun via nodeReg after the copyout, to avoid having -- refer to fun via nodeReg after the copyout, to avoid having
-- both live simultaneously; this sometimes enables fun to be -- both live simultaneously; this sometimes enables fun to be
......
...@@ -214,10 +214,11 @@ emitForeignCall safety results target args _ret ...@@ -214,10 +214,11 @@ emitForeignCall safety results target args _ret
return AssignedDirectly return AssignedDirectly
| otherwise = do | otherwise = do
dflags <- getDynFlags
updfr_off <- getUpdFrameOff updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target temp_target <- load_target_into_temp target
k <- newLabelC 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] -- see Note [safe foreign call convention]
emit $ emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth)) ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
......
...@@ -348,7 +348,8 @@ entryHeapCheck :: ClosureInfo ...@@ -348,7 +348,8 @@ entryHeapCheck :: ClosureInfo
-> FCode () -> FCode ()
entryHeapCheck cl_info offset nodeSet arity args code 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 is_fastf = case closureFunInfo cl_info of
Just (_, ArgGen _) -> False Just (_, ArgGen _) -> False
_otherwise -> True _otherwise -> True
...@@ -365,9 +366,9 @@ entryHeapCheck cl_info offset nodeSet arity args code ...@@ -365,9 +366,9 @@ entryHeapCheck cl_info offset nodeSet arity args code
Function (slow): Set R1 = node, call generic_gc -} Function (slow): Set R1 = node, call generic_gc -}
gc_call upd = setN <*> gc_lbl upd gc_call upd = setN <*> gc_lbl upd
gc_lbl upd gc_lbl upd
| is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp | is_thunk = mkDirectJump dflags (CmmReg $ CmmGlobal GCEnter1) [] sp
| is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp | is_fastf = mkDirectJump dflags (CmmReg $ CmmGlobal GCFun) [] sp
| otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd | otherwise = mkForeignJump dflags Slow (CmmReg $ CmmGlobal GCFun) args' upd
where sp = max offset upd where sp = max offset upd
{- DT (12/08/10) This is a little fishy, mainly the sp fix up amount. {- 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. - This is since the ncg inserts spills before the stack/heap check.
...@@ -447,8 +448,9 @@ altHeapCheck regs code ...@@ -447,8 +448,9 @@ altHeapCheck regs code
= case cannedGCEntryPoint regs of = case cannedGCEntryPoint regs of
Nothing -> genericGC code Nothing -> genericGC code
Just gc -> do Just gc -> do
dflags <- getDynFlags
lret <- newLabelC lret <- newLabelC
let (off, copyin) = copyInOflow NativeReturn (Young lret) regs let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
lcont <- newLabelC lcont <- newLabelC
emitOutOfLine lret (copyin <*> mkBranch lcont) emitOutOfLine lret (copyin <*> mkBranch lcont)
emitLabel lcont emitLabel lcont
...@@ -464,15 +466,16 @@ cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff ...@@ -464,15 +466,16 @@ cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
-> FCode a -> FCode a
-> FCode a -> FCode a
cannedGCReturnsTo cont_on_stack gc regs lret off code cannedGCReturnsTo cont_on_stack gc regs lret off code
= do updfr_sz <- getUpdFrameOff = do dflags <- getDynFlags
heapCheck False (gc_call gc updfr_sz) code updfr_sz <- getUpdFrameOff
heapCheck False (gc_call dflags gc updfr_sz) code
where where
reg_exprs = map (CmmReg . CmmLocal) regs reg_exprs = map (CmmReg . CmmLocal) regs
-- Note [stg_gc arguments] -- Note [stg_gc arguments]
gc_call label sp gc_call dflags label sp
| cont_on_stack = mkJumpReturnsTo label GC reg_exprs lret off sp | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
| otherwise = mkCallReturnsTo label GC reg_exprs lret off sp (0,[]) | otherwise = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
genericGC :: FCode a -> FCode a genericGC :: FCode a -> FCode a
genericGC code genericGC code
......
...@@ -78,12 +78,13 @@ import FastString ...@@ -78,12 +78,13 @@ import FastString
-- --
emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn results emitReturn results
= do { sequel <- getSequel; = do { dflags <- getDynFlags
; sequel <- getSequel
; updfr_off <- getUpdFrameOff ; updfr_off <- getUpdFrameOff
; case sequel of ; case sequel of
Return _ -> Return _ ->
do { adjustHpBackwards do { adjustHpBackwards
; emit (mkReturnSimple results updfr_off) } ; emit (mkReturnSimple dflags results updfr_off) }
AssignTo regs adjust -> AssignTo regs adjust ->
do { if adjust then adjustHpBackwards else return () do { if adjust then adjustHpBackwards else return ()
; emitMultiAssign regs results } ; emitMultiAssign regs results }
...@@ -109,18 +110,19 @@ emitCallWithExtraStack ...@@ -109,18 +110,19 @@ emitCallWithExtraStack
:: (Convention, Convention) -> CmmExpr -> [CmmExpr] :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
emitCallWithExtraStack (callConv, retConv) fun args extra_stack emitCallWithExtraStack (callConv, retConv) fun args extra_stack
= do { adjustHpBackwards = do { dflags <- getDynFlags
; adjustHpBackwards
; sequel <- getSequel ; sequel <- getSequel
; updfr_off <- getUpdFrameOff ; updfr_off <- getUpdFrameOff
; case sequel of ; case sequel of
Return _ -> do Return _ -> do
emit $ mkForeignJumpExtra callConv fun args updfr_off extra_stack emit $ mkForeignJumpExtra dflags callConv fun args updfr_off extra_stack
return AssignedDirectly return AssignedDirectly
AssignTo res_regs _ -> do AssignTo res_regs _ -> do
k <- newLabelC k <- newLabelC
let area = Young k let area = Young k
(off, copyin) = copyInOflow retConv area res_regs (off, copyin) = copyInOflow dflags retConv area res_regs
copyout = mkCallReturnsTo fun callConv args k off updfr_off copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
extra_stack extra_stack
emit (copyout <*> mkLabel k <*> copyin) emit (copyout <*> mkLabel k <*> copyin)
return (ReturnedTo k off) return (ReturnedTo k off)
...@@ -537,7 +539,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ...@@ -537,7 +539,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
; let args' = if node_points then (node : arg_regs) else arg_regs ; let args' = if node_points then (node : arg_regs) else arg_regs
conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall
else NativeDirectCall else NativeDirectCall
(offset, _) = mkCallEntry conv args' (offset, _) = mkCallEntry dflags conv args'
; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
} }
......
...@@ -725,8 +725,9 @@ emitOutOfLine l stmts = emitCgStmt (CgFork l stmts) ...@@ -725,8 +725,9 @@ emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-> [CmmFormal] -> CmmAGraph -> FCode () -> [CmmFormal] -> CmmAGraph -> FCode ()
emitProcWithConvention conv mb_info lbl args blocks emitProcWithConvention conv mb_info lbl args blocks
= do { us <- newUniqSupply = do { dflags <- getDynFlags
; let (offset, entry) = mkCallEntry conv args ; us <- newUniqSupply
; let (offset, entry) = mkCallEntry dflags conv args
blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
...@@ -783,10 +784,11 @@ mkCmmIfThen e tbranch = do ...@@ -783,10 +784,11 @@ mkCmmIfThen e tbranch = do
mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
-> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
dflags <- getDynFlags
k <- newLabelC k <- newLabelC
let area = Young k let area = Young k
(off, copyin) = copyInOflow retConv area results (off, copyin) = copyInOflow dflags retConv area results
copyout = mkCallReturnsTo f callConv actuals k off updfr_off extra_stack copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
return (copyout <*> mkLabel k <*> copyin) return (copyout <*> mkLabel k <*> copyin)
mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
......
...@@ -91,8 +91,6 @@ endif ...@@ -91,8 +91,6 @@ endif
@echo 'cGhcWithSMP = "$(GhcWithSMP)"' >> $@ @echo 'cGhcWithSMP = "$(GhcWithSMP)"' >> $@
@echo 'cGhcRTSWays :: String' >> $@ @echo 'cGhcRTSWays :: String' >> $@
@echo 'cGhcRTSWays = "$(GhcRTSWays)"' >> $@ @echo 'cGhcRTSWays = "$(GhcRTSWays)"' >> $@
@echo 'cGhcUnregisterised :: String' >> $@
@echo 'cGhcUnregisterised = "$(GhcUnregisterised)"' >> $@
@echo 'cGhcEnableTablesNextToCode :: String' >> $@ @echo 'cGhcEnableTablesNextToCode :: String' >> $@
@echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@ @echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@
@echo 'cLeadingUnderscore :: String' >> $@ @echo 'cLeadingUnderscore :: String' >> $@
......
...@@ -44,7 +44,6 @@ import Panic ...@@ -44,7 +44,6 @@ import Panic
import Binary import Binary
import SrcLoc import SrcLoc
import ErrUtils import ErrUtils
import Config
import FastMutInt import FastMutInt
import Unique import Unique
import Outputable import Outputable
...@@ -572,8 +571,8 @@ instance Binary ModIface where ...@@ -572,8 +571,8 @@ instance Binary ModIface where
getWayDescr :: DynFlags -> String getWayDescr :: DynFlags -> String
getWayDescr dflags getWayDescr dflags
| cGhcUnregisterised == "YES" = 'u':tag | platformUnregisterised (targetPlatform dflags) = 'u':tag
| otherwise = tag | otherwise = tag
where tag = buildTag dflags where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces -- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build. -- can't be used by a registerised build.
......
...@@ -45,7 +45,7 @@ llvmCodeGen dflags h us cmms ...@@ -45,7 +45,7 @@ llvmCodeGen dflags h us cmms
let lbl = strCLabel_llvm env $ case topInfoTable p of let lbl = strCLabel_llvm env $ case topInfoTable p of
Nothing -> l Nothing -> l
Just (Statics info_lbl _) -> info_lbl Just (Statics info_lbl _) -> info_lbl
env' = funInsert lbl llvmFunTy e env' = funInsert lbl (llvmFunTy dflags) e
in (d,env') in (d,env')
in do in do
showPass dflags "LlVM CodeGen" showPass dflags "LlVM CodeGen"
......
...@@ -31,7 +31,6 @@ import LlvmCodeGen.Regs ...@@ -31,7 +31,6 @@ import LlvmCodeGen.Regs
import CLabel import CLabel
import CgUtils ( activeStgRegs ) import CgUtils ( activeStgRegs )
import Config
import Constants import Constants
import DynFlags import DynFlags
import FastString import FastString
...@@ -84,23 +83,25 @@ widthToLlvmInt :: Width -> LlvmType ...@@ -84,23 +83,25 @@ widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt w = LMInt $ widthInBits w widthToLlvmInt w = LMInt $ widthInBits w
-- | GHC Call Convention for LLVM -- | GHC Call Convention for LLVM
llvmGhcCC :: LlvmCallConvention llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10