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, [])
......
...@@ -24,6 +24,7 @@ import CmmCallConv (assignArgumentsPos, ParamLocation(..)) ...@@ -24,6 +24,7 @@ import CmmCallConv (assignArgumentsPos, ParamLocation(..))
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags
import FastString import FastString
import ForeignCall import ForeignCall
import Outputable import Outputable
...@@ -172,31 +173,35 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ...@@ -172,31 +173,35 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r mkStore l r = mkMiddle $ CmmStore l r
---------- Control transfer ---------- Control transfer
mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
mkJump e actuals updfr_off = -> CmmAGraph
lastWithArgs Jump Old NativeNodeCall actuals updfr_off $ mkJump dflags e actuals updfr_off =
lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
mkDirectJump e actuals updfr_off = -> CmmAGraph
lastWithArgs Jump Old NativeDirectCall actuals updfr_off $ mkDirectJump dflags e actuals updfr_off =
lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkJumpGC :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
mkJumpGC e actuals updfr_off = -> CmmAGraph
lastWithArgs Jump Old GC actuals updfr_off $ mkJumpGC dflags e actuals updfr_off =
lastWithArgs dflags Jump Old GC actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset mkForeignJump :: DynFlags
-> Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkForeignJump conv e actuals updfr_off = mkForeignJump dflags conv e actuals updfr_off =
mkForeignJumpExtra conv e actuals updfr_off noExtraStack mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
mkForeignJumpExtra :: Convention -> CmmExpr -> [CmmActual] mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)]) -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
-> CmmAGraph -> CmmAGraph
mkForeignJumpExtra conv e actuals updfr_off extra_stack = mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack Jump Old conv actuals updfr_off extra_stack $ lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
...@@ -205,45 +210,47 @@ mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot) ...@@ -205,45 +210,47 @@ mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
mkReturn e actuals updfr_off = -> CmmAGraph
lastWithArgs Ret Old NativeReturn actuals updfr_off $ mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple actuals updfr_off = mkReturnSimple dflags actuals updfr_off =
mkReturn e actuals updfr_off mkReturn dflags e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
mkBranch :: BlockId -> CmmAGraph mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid) mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset mkFinalCall :: DynFlags
-> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkFinalCall f _ actuals updfr_off = mkFinalCall dflags f _ actuals updfr_off =
lastWithArgs Call Old NativeDirectCall actuals updfr_off $ lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0 toCall f Nothing updfr_off 0
mkCallReturnsTo :: CmmExpr -> Convention -> [CmmActual] mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
-> BlockId -> BlockId
-> ByteOff -> ByteOff
-> UpdFrameOffset -> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)]) -> (ByteOff, [(CmmExpr,ByteOff)])
-> CmmAGraph -> CmmAGraph
mkCallReturnsTo f callConv actuals ret_lbl ret_off updfr_off extra_stack = do mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack Call (Young ret_lbl) callConv actuals lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $ updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off toCall f (Just ret_lbl) updfr_off ret_off
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack). -- already on the stack).
mkJumpReturnsTo :: CmmExpr -> Convention -> [CmmActual] mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
-> BlockId -> BlockId
-> ByteOff -> ByteOff
-> UpdFrameOffset -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkJumpReturnsTo f callConv actuals ret_lbl ret_off updfr_off = do mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
lastWithArgs JumpRet (Young ret_lbl) callConv actuals updfr_off $ lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
toCall f (Just ret_lbl) updfr_off ret_off toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
...@@ -269,25 +276,26 @@ stackStubExpr w = CmmLit (CmmInt 0 w) ...@@ -269,25 +276,26 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- the variables in their spill slots. -- the variables in their spill slots.
-- Therefore, for copying arguments and results, we provide different -- 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. -- 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) copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn oneCopyOflowI conv area formals where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) -> type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
(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 -- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments. -- instructions to copy the arguments.
copyIn :: CopyIn copyIn :: CopyIn
copyIn oflow conv area formals = copyIn dflags oflow conv area formals =
foldr ci (init_offset, []) args' foldr ci (init_offset, []) args'
where ci (reg, RegisterParam r) (n, ms) = where ci (reg, RegisterParam r) (n, ms) =
(n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
init_offset = widthInBytes wordWidth -- infotable init_offset = widthInBytes wordWidth -- infotable
args = assignArgumentsPos conv localRegType formals args = assignArgumentsPos dflags conv localRegType formals
args' = foldl adjust [] args args' = foldl adjust [] args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst adjust rst x@(_, RegisterParam _) = x : rst
...@@ -303,7 +311,7 @@ oneCopyOflowI area (reg, off) (n, ms) = ...@@ -303,7 +311,7 @@ oneCopyOflowI area (reg, off) (n, ms) =
data Transfer = Call | JumpRet | Jump | Ret deriving Eq data Transfer = Call | JumpRet | Jump | Ret deriving Eq
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
-> UpdFrameOffset -> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
-> (Int, [GlobalReg], CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
...@@ -317,7 +325,7 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] ...@@ -317,7 +325,7 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-- the info table for return and adjust the offsets of the other -- the info table for return and adjust the offsets of the other
-- parameters. If this is a call instruction, we adjust the offsets -- parameters. If this is a call instruction, we adjust the offsets
-- of the other parameters. -- 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) (extra_stack_off, extra_stack_stuff)
= foldr co (init_offset, [], mkNop) (args' ++ stack_params) = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
where where
...@@ -347,7 +355,7 @@ copyOutOflow conv transfer area actuals updfr_off ...@@ -347,7 +355,7 @@ copyOutOflow conv transfer area actuals updfr_off
arg_offset = init_offset + extra_stack_off arg_offset = init_offset + extra_stack_off
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it 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 args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
...@@ -355,26 +363,27 @@ copyOutOflow conv transfer area actuals updfr_off ...@@ -355,26 +363,27 @@ copyOutOflow conv transfer area actuals updfr_off
mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph) mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry conv formals = copyInOflow conv Old formals mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph -> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last = lastWithArgs dflags transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack transfer area conv actuals lastWithArgsAndExtraStack dflags transfer area conv actuals
updfr_off noExtraStack last updfr_off noExtraStack last
lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual] lastWithArgsAndExtraStack :: DynFlags
-> Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)]) -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph -> CmmAGraph
lastWithArgsAndExtraStack transfer area conv actuals updfr_off lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
extra_stack last = extra_stack last =
copies <*> last outArgs regs copies <*> last outArgs regs
where where
(outArgs, regs, copies) = copyOutOflow conv transfer area actuals (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
updfr_off extra_stack updfr_off extra_stack
......
...@@ -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