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 ...@@ -111,7 +111,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
-- Info Tables -- Info Tables
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} data CmmTopInfo = TopInfo { info_tbl :: CmmInfoTable
, stack_info :: CmmStackInfo }
data CmmStackInfo data CmmStackInfo
= StackInfo { = StackInfo {
......
...@@ -18,7 +18,7 @@ module CmmBuildInfoTables ...@@ -18,7 +18,7 @@ module CmmBuildInfoTables
, TopSRT, emptySRT, srtToData , TopSRT, emptySRT, srtToData
, bundleCAFs , bundleCAFs
, lowerSafeForeignCalls , lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers , cafTransfers
, mkLiveness ) , mkLiveness )
where where
...@@ -98,7 +98,7 @@ foldSet = Set.foldr ...@@ -98,7 +98,7 @@ foldSet = Set.foldr
-- Also, don't forget to stop at the old end of the stack (oldByte), -- 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. -- which may differ depending on whether there is an update frame.
{-
type RegSlotInfo type RegSlotInfo
= ( Int -- Offset from oldest byte of Old area = ( Int -- Offset from oldest byte of Old area
, LocalReg -- The register , LocalReg -- The register
...@@ -172,15 +172,18 @@ live_ptrs oldByte slotEnv areaMap bid = ...@@ -172,15 +172,18 @@ live_ptrs oldByte slotEnv areaMap bid =
slots :: SubAreaSet -- The SubAreaSet for 'bid' slots :: SubAreaSet -- The SubAreaSet for 'bid'
slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
-}
-- Construct the stack maps for a procedure _if_ it needs an infotable. -- 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 -- When wouldn't a procedure need an infotable? If it is a procpoint that
-- is not the successor of a call. -- is not the successor of a call.
{-
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl
setInfoTableStackMap slotEnv areaMap setInfoTableStackMap slotEnv areaMap
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
(CmmGraph {g_entry = eid})) (CmmGraph {g_entry = eid}))
= updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t = updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
-}
setInfoTableStackMap _ _ t = t setInfoTableStackMap _ _ t = t
...@@ -500,8 +503,8 @@ lowerSafeForeignCall entry areaMap blocks bid m ...@@ -500,8 +503,8 @@ lowerSafeForeignCall entry areaMap blocks bid m
saveRetVals = foldl (<**>) mkNop $ map (M.mkMiddle . spill) rs saveRetVals = foldl (<**>) mkNop $ map (M.mkMiddle . spill) rs
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r) spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset) regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) 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 (CallArea area) areaMap) sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup area areaMap)
area = if succ == entry then Old else Young succ area = if succ == entry then Old else Young succ
w = widthInBytes $ typeWidth $ localRegType r w = widthInBytes $ typeWidth $ localRegType r
-- Note: The successor must be a procpoint, and we have already split, -- Note: The successor must be a procpoint, and we have already split,
......
...@@ -184,7 +184,7 @@ replaceLabels env g ...@@ -184,7 +184,7 @@ replaceLabels env g
exp :: CmmExpr -> CmmExpr exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) 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 exp e = e
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
......
...@@ -19,7 +19,7 @@ import Outputable ...@@ -19,7 +19,7 @@ import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops 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 mapTop (CmmData s ds) = CmmData s ds
data ValueDirection = Arguments | Results data ValueDirection = Arguments | Results
......
...@@ -18,8 +18,8 @@ module CmmExpr ...@@ -18,8 +18,8 @@ module CmmExpr
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList , regSetToList
, regUsedIn, regSlot , regUsedIn
, Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf , Area(..), SubArea, SubAreaSet, AreaMap
, module CmmMachOp , module CmmMachOp
, module CmmType , module CmmType
) )
...@@ -71,11 +71,6 @@ data CmmReg ...@@ -71,11 +71,6 @@ data CmmReg
-- | A stack area is either the stack slot where a variable is spilled -- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed. -- or the stack space where function arguments and results are passed.
data Area data Area
= RegSlot LocalReg
| CallArea AreaId
deriving (Eq, Ord)
data AreaId
= Old -- See Note [Old Area] = Old -- See Note [Old Area]
| Young BlockId -- Invariant: must be a continuation BlockId | Young BlockId -- Invariant: must be a continuation BlockId
-- See Note [Continuation BlockId] in CmmNode. -- See Note [Continuation BlockId] in CmmNode.
...@@ -286,17 +281,6 @@ reg `regUsedIn` CmmRegOff reg' _ = reg == reg' ...@@ -286,17 +281,6 @@ reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_ `regUsedIn` CmmStackSlot _ _ = False _ `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 [_$_] -- Stack slot use information for expressions and other types [_$_]
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -88,7 +88,7 @@ mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl] ...@@ -88,7 +88,7 @@ mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat) mkInfoTable _ (CmmData sec dat)
= return [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. | CmmNonInfoTable <- info -- Code without an info table. Easy.
= return [CmmProc Nothing entry_label blocks] = return [CmmProc Nothing entry_label blocks]
...@@ -97,7 +97,8 @@ mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks) ...@@ -97,7 +97,8 @@ mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks)
; return (top_decls ++ ; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts mkInfoTableAndCode info_lbl info_cts
entry_label blocks) } 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 type InfoTableContents = ( [CmmLit] -- The standard part
......
This diff is collapsed.
...@@ -21,7 +21,6 @@ import PprCmmExpr () ...@@ -21,7 +21,6 @@ import PprCmmExpr ()
import Hoopl import Hoopl
import Maybes import Maybes
import Outputable import Outputable
import UniqSet
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block -- Calculating what variables are live on entry to a basic block
...@@ -77,11 +76,7 @@ xferLive = mkBTransfer3 fst mid lst ...@@ -77,11 +76,7 @@ xferLive = mkBTransfer3 fst mid lst
mid :: CmmNode O O -> CmmLive -> CmmLive mid :: CmmNode O O -> CmmLive -> CmmLive
mid n f = gen_kill n f mid n f = gen_kill n f
lst :: CmmNode O C -> FactBase CmmLive -> CmmLive lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
-- slightly inefficient: kill is unnecessary for emptyRegSet lst n f = gen_kill n $ joinOutFacts liveLattice n f
lst n f = gen_kill n
$ case n of CmmCall{} -> emptyRegSet
CmmForeignCall{} -> emptyRegSet
_ -> joinOutFacts liveLattice n f
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Removing assignments to dead variables -- Removing assignments to dead variables
......
...@@ -310,14 +310,14 @@ instance UserOfSlots ForeignTarget where ...@@ -310,14 +310,14 @@ instance UserOfSlots ForeignTarget where
instance DefinerOfSlots (CmmNode e x) where instance DefinerOfSlots (CmmNode e x) where
foldSlotsDefd f z n = case n of foldSlotsDefd f z n = case n of
CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr) 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 _ -> z
where where
fold :: forall a b. fold :: forall a b.
DefinerOfSlots a => DefinerOfSlots a =>
(b -> SubArea -> b) -> b -> a -> b (b -> SubArea -> b) -> b -> a -> b
fold f z n = foldSlotsDefd f z n 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 -- mapping Expr in CmmNode
......
...@@ -230,35 +230,31 @@ lits :: { [ExtFCode CmmExpr] } ...@@ -230,35 +230,31 @@ lits :: { [ExtFCode CmmExpr] }
cmmproc :: { ExtCode } cmmproc :: { ExtCode }
-- TODO: add real SRT/info tables to parsed Cmm -- TODO: add real SRT/info tables to parsed Cmm
: info maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}' : info maybe_formals_without_hints '{' body '}'
{ do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <- { do ((entry_ret_label, info, live, formals), stmts) <-
getCgStmtsEC' $ loopDecls $ do { getCgStmtsEC' $ loopDecls $ do {
(entry_ret_label, info, live) <- $1; (entry_ret_label, info, live) <- $1;
formals <- sequence $2; formals <- sequence $2;
gc_block <- $3; $4;
frame <- $4; return (entry_ret_label, info, live, formals) }
$6;
return (entry_ret_label, info, live, formals, gc_block, frame) }
blks <- code (cgStmtsToBlocks stmts) 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 ';' | info maybe_formals_without_hints ';'
{ do (entry_ret_label, info, live) <- $1; { do (entry_ret_label, info, live) <- $1;
formals <- sequence $2; 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 -> {% withThisPackage $ \pkg ->
do newFunctionName $1 pkg do newFunctionName $1 pkg
((formals, gc_block, frame), stmts) <- (formals, stmts) <-
getCgStmtsEC' $ loopDecls $ do { getCgStmtsEC' $ loopDecls $ do {
formals <- sequence $2; formals <- sequence $2;
gc_block <- $3; $4;
frame <- $4; return formals }
$6;
return (formals, gc_block, frame) }
blks <- code (cgStmtsToBlocks stmts) 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 :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
...@@ -599,18 +595,7 @@ formals_without_hints :: { [ExtFCode LocalReg] } ...@@ -599,18 +595,7 @@ formals_without_hints :: { [ExtFCode LocalReg] }
formal_without_hint :: { ExtFCode LocalReg } formal_without_hint :: { ExtFCode LocalReg }
: type NAME { newLocal $1 $2 } : type NAME { newLocal $1 $2 }
maybe_frame :: { ExtFCode (Maybe UpdateFrame) } type :: { CmmType }
: {- 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 } : 'bits8' { b8 }
| typenot8 { $1 } | typenot8 { $1 }
......
...@@ -21,6 +21,7 @@ import CmmRewriteAssignments ...@@ -21,6 +21,7 @@ import CmmRewriteAssignments
import CmmStackLayout import CmmStackLayout
import CmmContFlowOpt import CmmContFlowOpt
import OptimizationFuel import OptimizationFuel
import CmmLayoutStack
import DynFlags import DynFlags
import ErrUtils import ErrUtils
...@@ -110,40 +111,45 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -110,40 +111,45 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Proc points ------------------- ----------- Proc points -------------------
let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
procPoints <- {-# SCC "minimalProcPointSet" #-} run $ minimalProcPointSet (targetPlatform dflags) callPPs 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 "layoutStack" #-} run $ cmmLayoutStack procPoints entry_off g
g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g dump Opt_D_dump_cmmz_sp "Layout Stack" g
dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
-- g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
----------- Sink and inline assignments ------------------- -- dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g --
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" 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 ------------------- ----------- Eliminate dead assignments -------------------
g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g
dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) --------------- -- ----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early -- -- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues -- g <- if opt_StubDeadValues
then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g -- then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
else return g -- else return g
dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g -- dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--
--------------- Stack layout ---------------- -- --------------- Stack layout ----------------
slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g -- slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
let spEntryMap = getSpEntryMap entry_off g -- let spEntryMap = getSpEntryMap entry_off g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () -- mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g -- let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return () -- mbpprTrace "areaMap" (ppr areaMap) $ return ()
--
------------ Manifest the stack pointer -------- -- ------------ Manifest the stack pointer --------
g <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g -- g <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
dump Opt_D_dump_cmmz_sp "Post manifestSP" g -- dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap. -- -- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update... -- -- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------ ------------- Split into separate procedures ------------
procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g procPointMap <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g
...@@ -157,12 +163,12 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ...@@ -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 let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return () mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs -- gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs -- dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs -- gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs -- dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
----------- Control-flow optimisations --------------- ----------- Control-flow optimisations ---------------
gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
module CmmProcPoint module CmmProcPoint
( ProcPointSet, Status(..) ( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet , callProcPoints, minimalProcPointSet
, addProcPointProtocols, splitAtProcPoints, procPointAnalysis , splitAtProcPoints, procPointAnalysis
) )
where where
...@@ -248,6 +248,8 @@ algorithm would be just as good, so that's what we do. ...@@ -248,6 +248,8 @@ algorithm would be just as good, so that's what we do.
-} -}
{-
data Protocol = Protocol Convention [CmmFormal] Area data Protocol = Protocol Convention [CmmFormal] Area
deriving Eq deriving Eq
instance Outputable Protocol where instance Outputable Protocol where
...@@ -371,6 +373,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) ...@@ -371,6 +373,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty)
return $ (b, foldl (flip insertBlock) bmap bs) return $ (b, foldl (flip insertBlock) bmap bs)
finish (b, bmap) = return $ insertBlock b bmap finish (b, bmap) = return $ insertBlock b bmap
skip b bs = insertBlock b `liftM` bs skip b bs = insertBlock b `liftM` bs
-}
-- At this point, we have found a set of procpoints, each of which should be -- At this point, we have found a set of procpoints, each of which should be
-- the entry point of a procedure. -- the entry point of a procedure.
......
...@@ -404,8 +404,8 @@ clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False ...@@ -404,8 +404,8 @@ clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
-- ToDo: Also catch MachOp case -- ToDo: Also catch MachOp case
clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) 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?) | 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 clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot (CallArea a') o') t) where f (CmmLoad (CmmStackSlot a' o') t)
= (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
f (CmmLoad e _) = containsStackSlot e f (CmmLoad e _) = containsStackSlot e
f (CmmMachOp _ es) = or (map f es) f (CmmMachOp _ es) = or (map f es)
...@@ -416,9 +416,6 @@ clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr ...@@ -416,9 +416,6 @@ clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
containsStackSlot (CmmStackSlot{}) = True containsStackSlot (CmmStackSlot{}) = True
containsStackSlot _ = False containsStackSlot _ = False
clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
f _ = False
clobbers _ (_, e) = f e clobbers _ (_, e) = f e
where f (CmmLoad (CmmStackSlot _ _) _) = False where f (CmmLoad (CmmStackSlot _ _) _) = False
f (CmmLoad{}) = True -- conservative f (CmmLoad{}) = True -- conservative
...@@ -432,7 +429,7 @@ clobbers _ (_, e) = f e ...@@ -432,7 +429,7 @@ clobbers _ (_, e) = f e
-- [ I32 ] -- [ I32 ]
-- [ F64 ] -- [ F64 ]
-- s' -w'- o' -- s' -w'- o'
type CallSubArea = (AreaId, Int, Int) -- area, offset, width type CallSubArea = (Area, Int, Int) -- area, offset, width
overlaps :: CallSubArea -> CallSubArea -> Bool overlaps :: CallSubArea -> CallSubArea -> Bool
overlaps (a, _, _) (a', _, _) | a /= a' = False overlaps (a, _, _) (a', _, _) | a /= a' = False
overlaps (_, o, w) (_, o', w') = overlaps (_, o, w) (_, o', w') =
...@@ -457,7 +454,7 @@ invalidateVolatile :: BlockId -> AssignmentMap -> AssignmentMap ...@@ -457,7 +454,7 @@ invalidateVolatile :: BlockId -> AssignmentMap -> AssignmentMap
invalidateVolatile k m = mapUFM p m invalidateVolatile k m = mapUFM p m
where p (AlwaysInline e) = if exp e then AlwaysInline e else NeverOptimize where p (AlwaysInline e) = if exp e then AlwaysInline e else NeverOptimize
where exp CmmLit{} = True where exp CmmLit{} = True
exp (CmmLoad (CmmStackSlot (CallArea (Young k')) _) _) exp (CmmLoad (CmmStackSlot (Young k') _) _)
| k' == k = False | k' == k = False
exp (CmmLoad (CmmStackSlot _ _) _) = True exp (CmmLoad (CmmStackSlot _ _) _) = True
exp (CmmMachOp _ es) = and (map exp es) exp (CmmMachOp _ es) = and (map exp es)
...@@ -596,10 +593,6 @@ assignmentRewrite = mkFRewrite3 first middle last ...@@ -596,10 +593,6 @@ assignmentRewrite = mkFRewrite3 first middle last
where rep = typeWidth (localRegType r) where rep = typeWidth (localRegType r)
_ -> old _ -> old
-- See Note [Soundness of store rewriting] -- 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 inlineExp _ old = old
inlinable :: CmmNode e x -> Bool inlinable :: CmmNode e x -> Bool
......
...@@ -12,6 +12,10 @@ module CmmSpillReload ...@@ -12,6 +12,10 @@ module CmmSpillReload
) )
where where
import Outputable
dualLivenessWithInsertion = panic "BANG BANG BANG BANG BANG BANG CLICK CLICK"
{-
import BlockId import BlockId
import Cmm import Cmm
import CmmUtils import CmmUtils
...@@ -164,3 +168,4 @@ instance Outputable DualLive where ...@@ -164,3 +168,4 @@ instance Outputable DualLive where
else (ppr_regs "live in regs =" regs), else (ppr_regs "live in regs =" regs),
if nullRegSet stack then PP.empty if nullRegSet stack then PP.empty
else (ppr_regs "live on stack =" stack)] else (ppr_regs "live on stack =" stack)]
-}
module CmmStackLayout () where
#if 0
{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} {-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
-- Norman likes local bindings -- Norman likes local bindings
-- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds -- 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 ...@@ -589,3 +594,4 @@ stubSlotsOnDeath g = liftM fst $ dataflowPassBwd g [] $ analRewBwd slotLattice
(stackStubExpr (widthFromBytes w)) (stackStubExpr (widthFromBytes w))
in case rst of Nothing -> Just (mkMiddle m <*> store) in case rst of Nothing -> Just (mkMiddle m <*> store)
Just g -> Just (g <*> store) Just g -> Just (g <*> store)
#endif
This diff is collapsed.
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
module OldCmm ( module OldCmm (
CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl, CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
ListGraph(..), ListGraph(..),
CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..),
CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual, CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
cmmMapGraph, cmmTopMapGraph, cmmMapGraph, cmmTopMapGraph,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
...@@ -53,13 +53,6 @@ import FastString ...@@ -53,13 +53,6 @@ import FastString
-- Info Tables -- 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. -- | A frame that is to be pushed before entry to the function.
-- Used to handle 'update' frames. -- Used to handle 'update' frames.
data UpdateFrame = data UpdateFrame =
...@@ -85,8 +78,8 @@ newtype ListGraph i = ListGraph [GenBasicBlock i] ...@@ -85,8 +78,8 @@ newtype ListGraph i = ListGraph [GenBasicBlock i]
-- across a whole compilation unit. -- across a whole compilation unit.
-- | Cmm with the info table as a data type -- | Cmm with the info table as a data type
type CmmGroup = GenCmmGroup CmmStatics CmmInfo (ListGraph CmmStmt) type CmmGroup = GenCmmGroup CmmStatics CmmInfoTable (ListGraph CmmStmt)
type CmmDecl = GenCmmDecl CmmStatics CmmInfo (ListGraph CmmStmt) type CmmDecl = GenCmmDecl CmmStatics CmmInfoTable (ListGraph CmmStmt)
-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info -- | 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 -- 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 ...@@ -66,9 +66,6 @@ instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) wh
instance PlatformOutputable CmmStmt where instance PlatformOutputable CmmStmt where
pprPlatform = pprStmt pprPlatform = pprStmt
instance PlatformOutputable CmmInfo where
pprPlatform = pprInfo
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
instance PlatformOutputable CmmSafety where instance PlatformOutputable CmmSafety where
...@@ -76,22 +73,6 @@ instance PlatformOutputable CmmSafety where ...@@ -76,22 +73,6 @@ instance PlatformOutputable CmmSafety where
pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_") pprPlatform _ CmmInterruptible = ptext (sLit "_interruptible_call_")
pprPlatform platform (CmmSafe srt) = pprPlatform platform srt 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]
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------