Commit 76999b60 authored by Simon Marlow's avatar Simon Marlow

New stack layout algorithm

Also:
 - improvements to code generation: push slow-call continuations
   on the stack instead of generating explicit continuations

 - remove unused CmmInfo wrapper type (replace with CmmInfoTable)

 - squash Area and AreaId together, remove now-unused RegSlot

 - comment out old unused stack-allocation code that no longer
   compiles after removal of RegSlot
parent cd389284
......@@ -111,7 +111,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
data CmmTopInfo = TopInfo { info_tbl :: CmmInfoTable
, stack_info :: CmmStackInfo }
data CmmStackInfo
= StackInfo {
......
......@@ -18,7 +18,7 @@ module CmmBuildInfoTables
, TopSRT, emptySRT, srtToData
, bundleCAFs
, lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers
, cafTransfers
, mkLiveness )
where
......@@ -98,7 +98,7 @@ foldSet = Set.foldr
-- Also, don't forget to stop at the old end of the stack (oldByte),
-- which may differ depending on whether there is an update frame.
{-
type RegSlotInfo
= ( Int -- Offset from oldest byte of Old area
, LocalReg -- The register
......@@ -172,15 +172,18 @@ live_ptrs oldByte slotEnv areaMap bid =
slots :: SubAreaSet -- The SubAreaSet for 'bid'
slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
-}
-- Construct the stack maps for a procedure _if_ it needs an infotable.
-- When wouldn't a procedure need an infotable? If it is a procpoint that
-- is not the successor of a call.
{-
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl
setInfoTableStackMap slotEnv areaMap
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
(CmmGraph {g_entry = eid}))
= updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
-}
setInfoTableStackMap _ _ t = t
......@@ -500,8 +503,8 @@ lowerSafeForeignCall entry areaMap blocks bid m
saveRetVals = foldl (<**>) mkNop $ map (M.mkMiddle . spill) rs
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap)
sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap)
where offset = w + expectJust "lowerForeign" Nothing -- XXX need to fix this: (Map.lookup (RegSlot r) areaMap)
sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup area areaMap)
area = if succ == entry then Old else Young succ
w = widthInBytes $ typeWidth $ localRegType r
-- Note: The successor must be a procpoint, and we have already split,
......
......@@ -184,7 +184,7 @@ replaceLabels env g
exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
exp e = e
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
......
......@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
where mapTop (CmmProc h l g) = CmmProc (info_tbl h) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
data ValueDirection = Arguments | Results
......
......@@ -18,8 +18,8 @@ module CmmExpr
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
, regUsedIn, regSlot
, Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
, regUsedIn
, Area(..), SubArea, SubAreaSet, AreaMap
, module CmmMachOp
, module CmmType
)
......@@ -71,11 +71,6 @@ data CmmReg
-- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed.
data Area
= RegSlot LocalReg
| CallArea AreaId
deriving (Eq, Ord)
data AreaId
= Old -- See Note [Old Area]
| Young BlockId -- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode.
......@@ -286,17 +281,6 @@ reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_ `regUsedIn` CmmStackSlot _ _ = False
-----------------------------------------------------------------------------
-- Stack slots
-----------------------------------------------------------------------------
isStackSlotOf :: CmmExpr -> LocalReg -> Bool
isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
isStackSlotOf _ _ = False
regSlot :: LocalReg -> CmmExpr
regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
-----------------------------------------------------------------------------
-- Stack slot use information for expressions and other types [_$_]
-----------------------------------------------------------------------------
......
......@@ -88,7 +88,7 @@ mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat)
= return [CmmData sec dat]
mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks)
mkInfoTable platform (CmmProc info entry_label blocks)
| CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks]
......@@ -97,7 +97,8 @@ mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks)
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
| otherwise = panic "mkInfoTable" -- Patern match overlap check not clever enough
| otherwise = panic "mkInfoTable"
-- Patern match overlap check not clever enough
-----------------------------------------------------
type InfoTableContents = ( [CmmLit] -- The standard part
......
This diff is collapsed.
......@@ -21,7 +21,6 @@ import PprCmmExpr ()
import Hoopl
import Maybes
import Outputable
import UniqSet
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
......@@ -77,11 +76,7 @@ xferLive = mkBTransfer3 fst mid lst
mid :: CmmNode O O -> CmmLive -> CmmLive
mid n f = gen_kill n f
lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
-- slightly inefficient: kill is unnecessary for emptyRegSet
lst n f = gen_kill n
$ case n of CmmCall{} -> emptyRegSet
CmmForeignCall{} -> emptyRegSet
_ -> joinOutFacts liveLattice n f
lst n f = gen_kill n $ joinOutFacts liveLattice n f
-----------------------------------------------------------------------------
-- Removing assignments to dead variables
......
......@@ -310,14 +310,14 @@ instance UserOfSlots ForeignTarget where
instance DefinerOfSlots (CmmNode e x) where
foldSlotsDefd f z n = case n of
CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
-- CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
_ -> z
where
fold :: forall a b.
DefinerOfSlots a =>
(b -> SubArea -> b) -> b -> a -> b
fold f z n = foldSlotsDefd f z n
foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
-- foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
-----------------------------------
-- mapping Expr in CmmNode
......
......@@ -230,35 +230,31 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
{ do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
: info maybe_formals_without_hints '{' body '}'
{ do ((entry_ret_label, info, live, formals), stmts) <-
getCgStmtsEC' $ loopDecls $ do {
(entry_ret_label, info, live) <- $1;
formals <- sequence $2;
gc_block <- $3;
frame <- $4;
$6;
return (entry_ret_label, info, live, formals, gc_block, frame) }
$4;
return (entry_ret_label, info, live, formals) }
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
code (emitInfoTableAndCode entry_ret_label info formals blks) }
| info maybe_formals_without_hints ';'
{ do (entry_ret_label, info, live) <- $1;
formals <- sequence $2;
code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
code (emitInfoTableAndCode entry_ret_label info formals []) }
| NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
| NAME maybe_formals_without_hints '{' body '}'
{% withThisPackage $ \pkg ->
do newFunctionName $1 pkg
((formals, gc_block, frame), stmts) <-
(formals, stmts) <-
getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2;
gc_block <- $3;
frame <- $4;
$6;
return (formals, gc_block, frame) }
$4;
return formals }
blks <- code (cgStmtsToBlocks stmts)
code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
code (emitProc CmmNonInfoTable (mkCmmCodeLabel pkg $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
......@@ -599,18 +595,7 @@ formals_without_hints :: { [ExtFCode LocalReg] }
formal_without_hint :: { ExtFCode LocalReg }
: type NAME { newLocal $1 $2 }
maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
: {- empty -} { return Nothing }
| 'jump' expr '(' exprs0 ')' { do { target <- $2;
args <- sequence $4;
return $ Just (UpdateFrame target args) } }
maybe_gc_block :: { ExtFCode (Maybe BlockId) }
: {- empty -} { return Nothing }
| 'goto' NAME
{ do l <- lookupLabel $2; return (Just l) }
type :: { CmmType }
type :: { CmmType }
: 'bits8' { b8 }
| typenot8 { $1 }
......
......@@ -21,6 +21,7 @@ import CmmRewriteAssignments
import CmmStackLayout
import CmmContFlowOpt
import OptimizationFuel
import CmmLayoutStack
import DynFlags
import ErrUtils
......@@ -110,40 +111,45 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Proc points -------------------
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g
dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
----------- Sink and inline assignments -------------------
g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
g <- {-# SCC "layoutStack" #-} run $ cmmLayoutStack procPoints entry_off g
dump Opt_D_dump_cmmz_sp "Layout Stack" g
-- g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
-- dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
--
-- ----------- Spills and reloads -------------------
-- g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g
-- dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
--
-- ----------- Sink and inline assignments -------------------
-- g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g
-- dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
--
----------- Eliminate dead assignments -------------------
g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g
dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues
then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
else return g
dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
let spEntryMap = getSpEntryMap entry_off g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
------------ Manifest the stack pointer --------
g <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
-- ----------- Zero dead stack slots (Debug only) ---------------
-- -- Debugging: stubbing slots on death can cause crashes early
-- g <- if opt_StubDeadValues
-- then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
-- else return g
-- dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--
-- --------------- Stack layout ----------------
-- slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
-- let spEntryMap = getSpEntryMap entry_off g
-- mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-- let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
-- mbpprTrace "areaMap" (ppr areaMap) $ return ()
--
-- ------------ Manifest the stack pointer --------
-- g <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
-- dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- -- UGH... manifestSP can require updates to the procPointMap.
-- -- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g
......@@ -157,12 +163,12 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
-- gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
-- dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
-- gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
-- dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations ---------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
......
......@@ -4,7 +4,7 @@
module CmmProcPoint
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, addProcPointProtocols, splitAtProcPoints, procPointAnalysis
, splitAtProcPoints, procPointAnalysis
)
where
......@@ -248,6 +248,8 @@ algorithm would be just as good, so that's what we do.
-}
{-
data Protocol = Protocol Convention [CmmFormal] Area
deriving Eq
instance Outputable Protocol where
......@@ -371,6 +373,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
return $ (b, foldl (flip insertBlock) bmap bs)
finish (b, bmap) = return $ insertBlock b bmap
skip b bs = insertBlock b `liftM` bs
-}
-- At this point, we have found a set of procpoints, each of which should be
-- the entry point of a procedure.
......
......@@ -404,8 +404,8 @@ clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
-- ToDo: Also catch MachOp case
clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
| getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot a' o') t)
= (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
f (CmmLoad e _) = containsStackSlot e
f (CmmMachOp _ es) = or (map f es)
......@@ -416,9 +416,6 @@ clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
containsStackSlot (CmmStackSlot{}) = True
containsStackSlot _ = False
clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
f _ = False
clobbers _ (_, e) = f e
where f (CmmLoad (CmmStackSlot _ _) _) = False
f (CmmLoad{}) = True -- conservative
......@@ -432,7 +429,7 @@ clobbers _ (_, e) = f e
-- [ I32 ]
-- [ F64 ]
-- s' -w'- o'
type CallSubArea = (AreaId, Int, Int) -- area, offset, width
type CallSubArea = (Area, Int, Int) -- area, offset, width
overlaps :: CallSubArea -> CallSubArea -> Bool
overlaps (a, _, _) (a', _, _) | a /= a' = False
overlaps (_, o, w) (_, o', w') =
......@@ -457,7 +454,7 @@ invalidateVolatile :: BlockId -> AssignmentMap -> AssignmentMap
invalidateVolatile k m = mapUFM p m
where p (AlwaysInline e) = if exp e then AlwaysInline e else NeverOptimize
where exp CmmLit{} = True
exp (CmmLoad (CmmStackSlot (CallArea (Young k')) _) _)
exp (CmmLoad (CmmStackSlot (Young k') _) _)
| k' == k = False
exp (CmmLoad (CmmStackSlot _ _) _) = True
exp (CmmMachOp _ es) = and (map exp es)
......@@ -596,10 +593,6 @@ assignmentRewrite = mkFRewrite3 first middle last
where rep = typeWidth (localRegType r)
_ -> old
-- See Note [Soundness of store rewriting]
inlineExp assign old@(CmmLoad (CmmStackSlot (RegSlot r) _) _)
= case lookupUFM assign r of
Just (AlwaysInline x) -> x
_ -> old
inlineExp _ old = old
inlinable :: CmmNode e x -> Bool
......
......@@ -12,6 +12,10 @@ module CmmSpillReload
)
where
import Outputable
dualLivenessWithInsertion = panic "BANG BANG BANG BANG BANG BANG CLICK CLICK"
{-
import BlockId
import Cmm
import CmmUtils
......@@ -164,3 +168,4 @@ instance Outputable DualLive where
else (ppr_regs "live in regs =" regs),
if nullRegSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
-}
module CmmStackLayout () where
#if 0
{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds
......@@ -589,3 +594,4 @@ stubSlotsOnDeath g = liftM fst $ dataflowPassBwd g [] $ analRewBwd slotLattice
(stackStubExpr (widthFromBytes w))
in case rst of Nothing -> Just (mkMiddle m <*> store)
Just g -> Just (g <*> store)
#endif
......@@ -3,14 +3,15 @@
module MkGraph
( CmmAGraph, CgStmt(..)
, (<*>), catAGraphs
, mkLabel, mkMiddle, mkLast
, mkLabel, mkMiddle, mkLast, outOfLine
, lgraphOfAGraph, labelAGraph
, stackStubExpr
, mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, lastWithArgs
, mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
, mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
, mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
, mkCbranch, mkSwitch
, mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
, copyInOflow, copyOutOflow
, toCall, Transfer(..)
)
where
......@@ -136,6 +137,9 @@ mkMiddle middle = unitOL (CgStmt middle)
mkLast :: CmmNode O C -> CmmAGraph
mkLast last = unitOL (CgLast last)
-- | A labelled code block; should end in a last node
outOfLine :: BlockId -> CmmAGraph -> CmmAGraph
outOfLine l g = unitOL (CgFork l g)
-- | allocate a fresh label for the entry point
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
......@@ -168,23 +172,30 @@ 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 $
lastWithArgs 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 $
lastWithArgs 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 $
lastWithArgs Jump Old GC actuals updfr_off $
toCall e Nothing updfr_off 0
mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkForeignJump conv e actuals updfr_off =
lastWithArgs Jump old conv actuals updfr_off $
lastWithArgs Jump Old conv actuals updfr_off $
toCall e Nothing updfr_off 0
mkForeignJumpExtra :: 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 $
toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
......@@ -195,15 +206,15 @@ mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturn e actuals updfr_off =
lastWithArgs Ret old NativeReturn actuals updfr_off $
lastWithArgs Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
-- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
-- where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple actuals updfr_off =
lastWithArgs Ret old NativeReturn actuals updfr_off $
lastWithArgs Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
......@@ -211,9 +222,20 @@ mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkFinalCall f _ actuals updfr_off =
lastWithArgs Call old NativeDirectCall actuals updfr_off $
lastWithArgs Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
mkCallReturnsTo :: 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
updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
......@@ -238,12 +260,9 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- 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)
copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O]
copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn oneCopyOflowI conv area formals
copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
(ByteOff, [CmmNode O O])
......@@ -264,26 +283,20 @@ copyIn oflow conv area formals =
adjust rst x@(_, RegisterParam _) = x : rst
-- Copy-in one arg, using overflow space if needed.
oneCopyOflowI, oneCopySlotI :: SlotCopier
oneCopyOflowI :: SlotCopier
oneCopyOflowI area (reg, off) (n, ms) =
(max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
where ty = localRegType reg
-- Copy-in one arg, using spill slots if needed -- used for calling conventions at
-- a procpoint that is not a return point. The offset is irrelevant here...
oneCopySlotI _ (reg, _) (n, ms) =
(n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
where ty = localRegType reg
w = widthInBytes (typeWidth ty)
-- Factoring out the common parts of the copyout functions yielded something
-- more complicated:
data Transfer = Call | Jump | Ret deriving Eq
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset ->
(Int, CmmAGraph)
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
-> (Int, CmmAGraph)
-- Generate code to move the actual parameters into the locations
-- required by the calling convention. This includes a store for the
......@@ -294,51 +307,61 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset
-- 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@(CallArea a) actuals updfr_off
= foldr co (init_offset, mkNop) args'
copyOutOflow conv transfer area actuals updfr_off
(extra_stack_off, extra_stack_stuff)
= foldr co (init_offset, mkNop) (args' ++ stack_params)
where
co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
stack_params = [ (e, StackParam (off + init_offset))
| (e,off) <- extra_stack_stuff ]
(setRA, init_offset) =
case a of Young id -> id `seq` -- Generate a store instruction for
case area of
Young id -> id `seq` -- Generate a store instruction for
-- the return address if making a call
if transfer == Call then
([(CmmLit (CmmBlock id), StackParam init_offset)],
widthInBytes wordWidth)
else ([], 0)
Old -> ([], updfr_off)
Old -> ([], updfr_off)
arg_offset = init_offset + extra_stack_off