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,17 +595,6 @@ 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 }
: '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
This diff is collapsed.
......@@ -16,7 +16,7 @@
module OldCmm (
CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
ListGraph(..),
CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..),
UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..),
CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
cmmMapGraph, cmmTopMapGraph,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
......@@ -53,13 +53,6 @@ import FastString
-- Info Tables
-----------------------------------------------------------------------------
data CmmInfo
= CmmInfo
(Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
-- JD: NOT USED BY NEW CODE GEN
(Maybe UpdateFrame) -- Update frame
CmmInfoTable -- Info table
-- | A frame that is to be pushed before entry to the function.
-- Used to handle 'update' frames.
data UpdateFrame =
......@@ -85,8 +78,8 @@ newtype ListGraph i = ListGraph [GenBasicBlock i]
-- across a whole compilation unit.
-- | Cmm with the info table as a data type
type CmmGroup = GenCmmGroup CmmStatics CmmInfo (ListGraph CmmStmt)
type CmmDecl = GenCmmDecl CmmStatics CmmInfo (ListGraph CmmStmt)
type CmmGroup = GenCmmGroup CmmStatics CmmInfoTable (ListGraph CmmStmt)
type CmmDecl = GenCmmDecl CmmStatics CmmInfoTable (ListGraph CmmStmt)
-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
-- table label. If we are building without tables-next-to-code there will be no statics
......
......@@ -66,9 +66,6 @@ instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) wh
instance PlatformOutputable CmmStmt where
pprPlatform = pprStmt
instance PlatformOutputable CmmInfo where
pprPlatform = pprInfo
-- --------------------------------------------------------------------------
instance PlatformOutputable CmmSafety where
......@@ -76,22 +73,6 @@ instance PlatformOutputable CmmSafety where
pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_")
pprPlatform platform (CmmSafe srt) = pprPlatform platform srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
-- but will work for now.
--
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
pprInfo :: Platform -> CmmInfo -> SDoc
pprInfo platform (CmmInfo _gc_target update_frame info_table) =
vcat [{-ptext (sLit "gc_target: ") <>
maybe (ptext (sLit "<none>")) ppr gc_target,-}
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>"))
(pprUpdateFrame platform)
update_frame,
pprPlatform platform info_table]
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
......
......@@ -248,12 +248,8 @@ pprLocalReg (LocalReg uniq rep)
-- Stack areas
pprArea :: Area -> SDoc
pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
pprArea (CallArea id) = pprAreaId id
pprAreaId :: AreaId -> SDoc
pprAreaId Old = text "old"
pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
pprArea Old = text "old"
pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
-- needs to be kept in syn with CmmExpr.hs.GlobalReg
--
......
......@@ -67,10 +67,9 @@ emitClosureCodeAndInfoTable cl_info args body
-- Convert from 'ClosureInfo' to 'CmmInfo'.
-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
mkCmmInfo :: ClosureInfo -> FCode CmmInfo
mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
mkCmmInfo cl_info
= return (CmmInfo gc_target Nothing $
CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info,
= return (CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info,
cit_rep = closureSMRep cl_info,
cit_prof = prof,
cit_srt = closureSRT cl_info })
......@@ -80,14 +79,6 @@ mkCmmInfo cl_info
ty_descr_w8 = stringToWord8s (closureTypeDescr cl_info)
val_descr_w8 = stringToWord8s (closureValDescr cl_info)
-- The gc_target is to inform the CPS pass when it inserts a stack check.
-- Since that pass isn't used yet we'll punt for now.
-- When the CPS pass is fully integrated, this should
-- be replaced by the label that any heap check jumped to,
-- so that branch can be shared by both the heap (from codeGen)
-- and stack checks (from the CPS pass).
gc_target = panic "TODO: gc_target"
-------------------------------------------------------------------------
--
-- Generating the info table and code for a return point
......@@ -106,8 +97,7 @@ emitReturnTarget name stmts
; blks <- cgStmtsToBlocks stmts
; frame <- mkStackLayout
; let smrep = mkStackRep (mkLiveness frame)
info = CmmInfo gc_target Nothing info_tbl
info_tbl = CmmInfoTable { cit_lbl = info_lbl
info = CmmInfoTable { cit_lbl = info_lbl
, cit_prof = NoProfilingInfo
, cit_rep = smrep
, cit_srt = srt_info }
......@@ -119,14 +109,6 @@ emitReturnTarget name stmts
info_lbl = mkReturnInfoLabel uniq
entry_lbl = mkReturnPtLabel uniq
-- The gc_target is to inform the CPS pass when it inserts a stack check.
-- Since that pass isn't used yet we'll punt for now.
-- When the CPS pass is fully integrated, this should
-- be replaced by the label that any heap check jumped to,
-- so that branch can be shared by both the heap (from codeGen)
-- and stack checks (from the CPS pass).
gc_target = panic "TODO: gc_target"
-- Build stack layout information from the state of the 'FCode' monad.
-- Should go away once 'codeGen' starts using the CPS conversion
-- pass to handle the stack. Until then, this is really just
......@@ -378,7 +360,7 @@ funInfoTable info_ptr
emitInfoTableAndCode
:: CLabel -- Label of entry or ret
-> CmmInfo -- ...the info table
-> CmmInfoTable -- ...the info table
-> [CmmFormal] -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
......
......@@ -728,7 +728,7 @@ emitDecl decl
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
emitProc info lbl [] blocks
= do { let proc_block = CmmProc info lbl (ListGraph blocks)
; state <- getState
......@@ -740,7 +740,7 @@ emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
; emitProc CmmNonInfoTable lbl [] blks }
-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
......
......@@ -596,7 +596,7 @@ pushUpdateFrame es body
offset <- foldM push updfr es
withUpdFrameOff offset body
where push off e =
do emitStore (CmmStackSlot (CallArea Old) base) e
do emitStore (CmmStackSlot Old base) e
return base
where base = off + widthInBytes (cmmExprWidth e)
......
......@@ -532,14 +532,7 @@ cgTailCall fun_id fun_info args = do
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
EnterIt -> ASSERT( null args ) -- Discarding arguments
do { let entry = entryCode (closureInfoPtr fun)
; [ret,call] <- forkAlts [
getCode $
emitReturn [fun], -- Is tagged; no need to untag
getCode $ do -- Not tagged
emitCall (NativeNodeCall, NativeReturn) entry [fun]
]
; emit =<< mkCmmIfThenElse (cmmIsTagged fun) ret call }
emitEnter fun
SlowCall -> do -- A slow function call via the RTS apply routines
{ tickySlowCall lf_info args
......@@ -565,6 +558,66 @@ cgTailCall fun_id fun_info args = do
node_points = nodeMustPointToIt lf_info
emitEnter :: CmmExpr -> FCode ()
emitEnter fun = do
{ adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; case sequel of
-- For a return, we have the option of generating a tag-test or
-- not. If the value is tagged, we can return directly, which
-- is quicker than entering the value. This is a code
-- size/speed trade-off: when optimising for speed rather than
-- size we could generate the tag test.
--
-- Right now, we do what the old codegen did, and omit the tag
-- test, just generating an enter.
Return _ -> do
{ let entry = entryCode $ closureInfoPtr $ CmmReg nodeReg
; emit $ mkForeignJump NativeNodeCall entry
[cmmUntag fun] updfr_off
}
-- The result will be scrutinised in the sequel. This is where
-- we generate a tag-test to avoid entering the closure if
-- possible.
--
-- The generated code will be something like this:
--
-- R1 = fun -- copyout
-- if (fun & 7 != 0) goto Lcall else goto Lret
-- Lcall:
-- call [fun] returns to Lret
-- Lret:
-- fun' = R1 -- copyin
-- ...
--
-- Note in particular that the label Lret is used as a
-- destination by both the tag-test and the call. This is
-- becase Lret will necessarily be a proc-point, and we want to
-- ensure that we generate only one proc-point for this
-- sequence.
--
AssignTo res_regs _ -> do
{ lret <- newLabelC
; lcall <- newLabelC
; let area = Young lret
; let (off, copyin) = copyInOflow NativeReturn area res_regs
(outArgs, copyout) = copyOutOflow NativeNodeCall Call area
[fun] updfr_off (0,[])
; let entry = entryCode (closureInfoPtr fun)
the_call = toCall entry (Just lret) updfr_off off outArgs
; emit $
copyout <*>
mkCbranch (cmmIsTagged fun) lret lcall <*>
outOfLine lcall the_call <*>
mkLabel lret <*>
copyin
}
}
{- Note [case on Bool]
~~~~~~~~~~~~~~~~~~~
A case on a Boolean value does two things:
......
......@@ -184,7 +184,7 @@ emitSaveThreadState :: BlockId -> FCode ()
emitSaveThreadState bid = do
-- CurrentTSO->stackobj->sp = Sp;
emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
(CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))