Commit 6bc92166 authored by dias@eecs.harvard.edu's avatar dias@eecs.harvard.edu

Removed warnings, made Haddock happy, added examples in documentation

The interesting examples talk about our story with heap checks in
case alternatives and our story with the case scrutinee as a Boolean.
parent c62b824e
......@@ -109,10 +109,10 @@ live_ptrs oldByte slotEnv areaMap bid =
if off == w && widthInBytes (typeWidth ty) == w then
(expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
else panic "live_ptrs: only part of a variable live at a proc point"
add_slot rst (CallArea Old, off, w) =
add_slot rst (CallArea Old, _, _) =
rst -- the update frame (or return infotable) should be live
-- would be nice to check that only that part of the callarea is live...
add_slot rst c@((CallArea _), _, _) =
add_slot rst ((CallArea _), _, _) =
rst
-- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
-- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
......@@ -127,10 +127,10 @@ live_ptrs oldByte slotEnv areaMap bid =
-- Construct the stack maps for the given procedure.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables
setInfoTableStackMap _ _ t@(NoInfoTable _) = t
setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable info bid updfr_off) =
setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
setInfoTableStackMap slotEnv areaMap
t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))
t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks))
procpoints) =
case blockSetToList procpoints of
[bid] ->
......@@ -250,9 +250,7 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t
buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet ->
FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
buildSRTs topSRT topCAFMap cafs =
-- This is surely the wrong way to get names, as in BlockId
do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
let liftCAF lbl () z = -- get CAFs for functions without static closures
do let liftCAF lbl () z = -- get CAFs for functions without static closures
case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
Nothing -> addToFM z lbl ()
sub_srt topSRT localCafs =
......@@ -292,7 +290,7 @@ buildSRTs topSRT topCAFMap cafs =
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] ->
FuelMonad (Maybe CmmTopZ, C_SRT)
procpointSRT top_srt top_table [] =
procpointSRT _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
......@@ -331,7 +329,7 @@ to_SRT top_srt off len bmp
-- Any procedure referring to a non-static CAF c must keep live the
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ t@(CmmData _ _) = Nothing
localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
case infoTbl of
CmmInfoTable False _ _ _ ->
......@@ -382,12 +380,12 @@ bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t)
-- Construct the SRTs for the given procedure.
setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
FuelMonad (TopSRT, [CmmTopForInfoTables])
setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable p procpoints)) =
setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
case blockSetToList procpoints of
[bid] -> setSRT cafs topCAFMap topSRT t
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path
setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable info bid _)) =
[_] -> setSRT cafs topCAFMap topSRT t
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path
setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
setSRT cafs topCAFMap topSRT t
setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
......@@ -406,7 +404,7 @@ updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints)
ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
updInfo toVars toSrt (NoInfoTable _) = panic "can't update NoInfoTable"
updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
updInfo _ _ _ = panic "unexpected arg to updInfo"
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo
......@@ -418,7 +416,7 @@ updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
(ThunkInfo c s) -> ThunkInfo c (toSrt s)
(ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
(ContInfo v s) -> ContInfo (toVars v) (toSrt s)
updInfoTbl toVars toSrt t@(CmmInfo _ _ CmmNonInfoTable) = t
updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
-- Lower the CmmTopForInfoTables type down to good old CmmTopZ
-- by emitting info tables as data where necessary.
......@@ -437,16 +435,16 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
extendEnvsForSafeForeignCalls cafEnv slotEnv g =
fold_blocks block (cafEnv, slotEnv) g
where block b@(Block _ _ t) z =
where block b z =
tail ( bt_last_in cafTransfers (lookupFn cafEnv) l
, bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
z head
where (head, last) = goto_end (G.unzip b)
l = case last of LastOther l -> l
LastExit -> panic "extendEnvs lastExit"
tail lives z (ZFirst _ _) = z
tail _ z (ZFirst _ _) = z
tail lives@(cafs, slots) (cafEnv, slotEnv)
(ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) =
(ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
let slots' = removeLiveSlotDefs slots m
slotEnv' = extendBlockEnv slotEnv bid slots'
cafEnv' = extendBlockEnv cafEnv bid cafs
......@@ -489,11 +487,9 @@ data SafeState = State { s_blocks :: BlockEnv CmmBlock
, s_safeCalls :: [CmmTopForInfoTables]}
lowerSafeForeignCalls
:: ProcPointSet -> [[CmmTopForInfoTables]] ->
CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
lowerSafeForeignCalls _ rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
lowerSafeForeignCalls procpoints rst
t@(CmmProc info l args g@(LGraph entry off blocks)) = do
:: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
let init = return $ State emptyBlockEnv emptyBlockSet []
let block b@(Block bid _ _) z = do
state@(State {s_pps = ppset, s_blocks = blocks}) <- z
......@@ -510,7 +506,7 @@ lowerSafeForeignCalls procpoints rst
-- Check for foreign calls -- if none, then we can avoid copying the block.
hasSafeForeignCall :: CmmBlock -> Bool
hasSafeForeignCall (Block _ _ t) = tail t
where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) t) = True
where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
tail (ZTail _ t) = tail t
tail (ZLast _) = False
......@@ -536,7 +532,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
-- to lower a safe foreign call to a sequence of unsafe calls.
lowerSafeForeignCall ::
SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
lowerSafeForeignCall state m@(MidForeignCall (Safe infotable updfr) _ _ _) tail = do
lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
......
......@@ -116,7 +116,7 @@ cpsTop hsc_env (CmmProc h l args g) =
mapM (dump Opt_D_dump_cmmz "after splitting") gs
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
......
......@@ -111,7 +111,7 @@ hash_block (Block _ _ t) =
hash_lit (CmmLabel _) = 119 -- ugh
hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
hash_lit (CmmBlock id) = 191 -- ugh
hash_lit (CmmBlock _) = 191 -- ugh
hash_lit (CmmHighStackMark) = cvt 313
hash_tgt (ForeignTarget e _) = hash_e e
hash_tgt (PrimTarget _) = 31 -- lots of these
......
......@@ -44,7 +44,7 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz
<*> mkStmts ss
where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
......
......@@ -385,7 +385,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
-- Input invariant: A block should only be reachable from a single ProcPoint.
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
splitAtProcPoints entry_label callPPs procPoints procMap areaMap
splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
(CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
g@(LGraph entry e_off blocks)) =
do -- Build a map from procpoints to the blocks they reach
......@@ -402,7 +402,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
graph' = extendBlockEnv graph bid b
graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
graphEnv <- return {- $ pprTrace "graphEnv" (ppr graphEnv_pre) -} graphEnv_pre
graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
-- Build a map from proc point BlockId to labels for their new procedures
let add_label map pp = return $ addToFM map pp lbl
where lbl = if pp == entry then entry_label else blockLbl pp
......@@ -459,7 +459,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
graphEnv_pre
let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
let to_proc (bid, g) | elemBlockSet bid callPPs =
if bid == entry then
CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
else
......@@ -476,9 +476,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
(expectJust "block_order" $ lookupBlockEnv block_order bid')
procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
return -- $ pprTrace "procLabels" (ppr procLabels)
-- $ pprTrace "splitting graphs" (ppr procs)
$ procs
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
----------------------------------------------------------------
......
......@@ -119,17 +119,17 @@ middleDualLiveness live m =
lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
lastDualLiveness env l = last l
where last (LastBranch id) = env id
last l@(LastCall tgt Nothing _ _) = changeRegs (gen l . kill l) empty
last l@(LastCall tgt (Just k) _ _) =
last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty
last l@(LastCall _ (Just k) _ _) =
-- nothing can be live in registers at this point, unless safe foreign call
let live = env k
live_in = DualLive (on_stack live) (gen l emptyRegSet)
in if isEmptyUniqSet (in_regs live) then live_in
else pprTrace "Offending party:" (ppr k <+> ppr live) $
panic "live values in registers at call continuation"
last l@(LastCondBranch e t f) =
last l@(LastCondBranch _ t f) =
changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
last l@(LastSwitch e tbl) = changeRegs (gen l . kill l) $ dualUnionList $
last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $
map env (catMaybes tbl)
empty = fact_bot dualLiveLattice
......@@ -254,10 +254,10 @@ akill a live = foldRegsUsed deleteFromAvail live a
middleAvail :: Middle -> AvailRegs -> AvailRegs
middleAvail m = middle m
where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
middle' (MidComment {}) live = live
middle' (MidAssign lhs _expr) live = akill lhs live
middle' (MidStore {}) live = live
middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet
middle' (MidComment {}) live = live
middle' (MidAssign lhs _expr) live = akill lhs live
middle' (MidStore {}) live = live
middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet
lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
......
......@@ -147,7 +147,7 @@ liveLastOut env l =
case l of
LastCall _ Nothing n _ ->
add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
LastCall _ (Just k) n (Just upd_n) ->
LastCall _ (Just k) n (Just _) ->
add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
LastCall _ (Just k) n Nothing ->
add_area (CallArea (Young k)) n out
......@@ -286,7 +286,7 @@ allocSlotFrom ig areaSize from areaMap area =
-- Note: The stack pointer only has to be younger than the youngest live stack slot
-- at proc points. Otherwise, the stack pointer can point anywhere.
layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap
layout procPoints env g@(LGraph _ entrySp _) =
layout procPoints env g =
let builder = areaBuilder
ig = (igraph builder env g, builder)
env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
......@@ -386,7 +386,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
middle spOff m = mapExpDeepMiddle (replSlot spOff) m
last spOff l = mapExpDeepLast (replSlot spOff) l
replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
replSlot spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark
replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
replSlot _ e = e
-- The block must establish the SP expected at each successsor.
......@@ -419,7 +419,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
maxSlot :: (Area -> Int) -> CmmGraph -> Int
maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
add z (a, i, w) = max z (slotOff a + i)
add z (a, i, _) = max z (slotOff a + i)
-----------------------------------------------------------------------------
-- | Sanity check: stub pointers immediately after they die
......
......@@ -70,7 +70,7 @@ primRepForeignHint IntRep = SignedHint
primRepForeignHint WordRep = NoHint
primRepForeignHint Int64Rep = SignedHint
primRepForeignHint Word64Rep = NoHint
primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
......
......@@ -310,7 +310,7 @@ withUnique ofU = AGraph f
f' g
outOfLine (AGraph f) = AGraph f'
where f' g@(Graph tail' blocks') =
where f' (Graph tail' blocks') =
do Graph emptyEntrance blocks <- f emptyGraph
note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
return $ Graph tail' (blocks `plusBlockEnv` blocks')
......
module OptimizationFuel
( OptimizationFuel , canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
, OptFuelState, initOptFuelState --, setTotalFuel
, tankFilledTo, diffFuel
, FuelConsumer
......
......@@ -64,7 +64,7 @@ data Middle
| MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
| MidForeignCall -- A foreign call;
| MidForeignCall -- A foreign call; see Note [Foreign calls]
ForeignSafety -- Is it a safe or unsafe call?
MidCallTarget -- call target and convention
CmmFormals -- zero or more results
......@@ -142,6 +142,33 @@ data ValueDirection = Arguments | Results
-- Arguments go with procedure definitions, jumps, and arguments to calls
-- Results go with returns and with results of calls.
deriving Eq
{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
Unsafe ones are easy: think of them as a "fat machine instruction".
Safe ones are trickier. A safe foreign call
r = f(x)
ultimately expands to
push "return address" -- Never used to return to;
-- just points an info table
save registers into TSO
call suspendThread
r = f(x) -- Make the call
call resumeThread
restore registers
pop "return address"
We cannot "lower" a safe foreign call to this sequence of Cmms, because
after we've saved Sp all the Cmm optimiser's assumptions are broken.
Furthermore, currently the smart Cmm constructors know the calling
conventions for Haskell, the garbage collector, etc, and "lower" them
so that a LastCall passes no parameters or results. But the smart
constructors do *not* (currently) know the foreign call conventions.
For these reasons use MidForeignCall for all calls. The only annoying thing
is that a safe foreign call needs an info table.
-}
----------------------------------------------------------------------
----- Splicing between blocks
......
......@@ -900,7 +900,7 @@ backward_rew check_maybe = back
rewrite start g exit_fact fuel =
let Graph entry blockenv = g
blocks = reverse $ G.postorder_dfs_from blockenv entry
in do { (FP env in_fact _ _ _, _) <- -- don't drop the entry fact!
in do { (FP _ in_fact _ _ _, _) <- -- don't drop the entry fact!
solve depth name start transfers rewrites g exit_fact fuel
--; env <- getAllFacts
-- ; my_trace "facts after solving" (ppr env) $ return ()
......@@ -1070,11 +1070,11 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
m f a -> m f a
subAnalysis' m =
do { a <- subAnalysis $
do { a <- m; facts <- getAllFacts
do { a <- m; -- facts <- getAllFacts
; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
return a }
; facts <- getAllFacts
-- ; facts <- getAllFacts
; -- my_trace "in parent analysis facts are" (pprFacts facts) $
return a }
where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
-- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
......@@ -84,7 +84,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
(_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
(addIdReps [])
-- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs srt_info
; forkClosureBody (closureCodeBody True id closure_info ccs
(nonVoidIds args) (length args) body fv_details)
; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
......@@ -293,7 +293,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
-- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
-- (b) ignore Sequel from context; use empty Sequel
-- And compile the body
closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args)
closureCodeBody False bndr closure_info cc (nonVoidIds args)
(length args) body fv_details
-- BUILD THE OBJECT
......@@ -361,7 +361,6 @@ closureCodeBody :: Bool -- whether this is a top-level binding
-> Id -- the closure's name
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> C_SRT
-> [NonVoid Id] -- incoming args to the closure
-> Int -- arity, including void args
-> StgExpr
......@@ -381,12 +380,12 @@ closureCodeBody :: Bool -- whether this is a top-level binding
argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
| length args == 0 -- No args i.e. thunk
= emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
(\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body)
(\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
= ASSERT( length args > 0 )
do { -- Allocate the global ticky counter,
-- and establish the ticky-counter
......@@ -407,7 +406,7 @@ closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
; granYield arg_regs node_points
-- Main payload
; entryHeapCheck node arity arg_regs srt $ do
; entryHeapCheck node arity arg_regs $ do
{ enterCostCentre cl_info cc body
; fv_bindings <- mapM bind_fv fv_details
; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
......@@ -454,15 +453,15 @@ mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
-----------------------------------------
thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
C_SRT -> LocalReg -> Int -> StgExpr -> FCode ()
thunkCode cl_info fv_details cc srt node arity body
LocalReg -> Int -> StgExpr -> FCode ()
thunkCode cl_info fv_details cc node arity body
= do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
; tickyEnterThunk cl_info
; ldvEnterClosure cl_info -- NB: Node always points when profiling
; granThunk node_points
-- Heap overflow check
; entryHeapCheck node arity [] srt $ do
; entryHeapCheck node arity [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
whenC (blackHoleOnEntry cl_info && node_points)
......
......@@ -115,10 +115,10 @@ cgLetNoEscapeRhs local_cc bndr rhs =
; return info
}
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
= cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
= cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
-- For a constructor RHS we want to generate a single chunk of
-- code which can be jumped to from many places, which will
-- return the constructor. It's easy; just behave as if it
......@@ -129,17 +129,15 @@ cgLetNoEscapeClosure
:: Id -- binder
-> Maybe LocalReg -- Slot for saved current cost centre
-> CostCentreStack -- XXX: *** NOT USED *** why not?
-> SRT
-> [NonVoid Id] -- Args (as in \ args -> body)
-> StgExpr -- Body (as in above)
-> FCode CgIdInfo
cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
= do { arg_regs <- forkProc $ do
{ restoreCurrentCostCentre cc_slot
; arg_regs <- bindArgsToRegs args
; c_srt <- getSRTInfo srt
; altHeapCheck arg_regs c_srt (cgExpr body)
; altHeapCheck arg_regs (cgExpr body)
-- Using altHeapCheck just reduces
-- instructions to save on stack
; return arg_regs }
......@@ -262,11 +260,14 @@ data GcPlan
-- of the case alternative(s) into the upstream check
-------------------------------------
-- See Note [case on Bool]
cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
-- | isBoolTy (idType bndr)
-- , isDeadBndr bndr
-- =
{-
cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
| isBoolTy (idType bndr)
, isDeadBndr bndr
=
-}
cgCase scrut bndr srt alt_type alts
= do { up_hp_usg <- getVirtHp -- Upstream heap usage
......@@ -280,10 +281,10 @@ cgCase scrut bndr srt alt_type alts
gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
; mb_cc <- maybeSaveCostCentre simple_scrut
; c_srt <- getSRTInfo srt
; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
; restoreCurrentCostCentre mb_cc
-- JD: We need Note: [Better Alt Heap Checks]
; bindArgsToRegs ret_bndrs
; cgAlts gc_plan (NonVoid bndr) alt_type alts }
......@@ -402,9 +403,8 @@ cgAltRhss gc_plan bndr alts
maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
maybeAltHeapCheck NoGcInAlts code
= code
maybeAltHeapCheck (GcInAlts regs srt) code
= do { c_srt <- getSRTInfo srt
; altHeapCheck regs c_srt code }
maybeAltHeapCheck (GcInAlts regs _) code
= altHeapCheck regs code
-----------------------------------------------------------------------------
-- Tail calls
......@@ -482,4 +482,77 @@ cgTailCall fun_id fun_info args
node_points = nodeMustPointToIt lf_info
{- Note [case on Bool]
~~~~~~~~~~~~~~~~~~~
A case on a Boolean value does two things:
1. It looks up the Boolean in a closure table and assigns the
result to the binder.
2. It branches to the True or False case through analysis
of the closure assigned to the binder.
But the indirection through the closure table is unnecessary
if the assignment to the binder will be dead code (use isDeadBndr).
The following example illustrates how badly the code turns out:
STG:
case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 {
GHC.Bool.False -> <true code> // sbH8 dead
GHC.Bool.True -> <false code> // sbH8 dead
};
Cmm:
_s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign
_ccsW::I64 = %MO_F_Le_W64(_s7Hx::F64, _s7HD::F64); // MidAssign
// emitReturn // MidComment
_sbH8::I64 = I64[ghczmprim_GHCziBool_Bool_closure_tbl + (_ccsW::I64 << 3)]; // MidAssign
_ccsX::I64 = _sbH8::I64 & 7; // MidAssign
if (_ccsX::I64 >= 2) goto ccsH; else goto ccsI; // LastCondBranch
The assignments to _sbH8 and _ccsX are completely unnecessary.
Instead, we should branch based on the value of _ccsW.
-}
{- Note [Better Alt Heap Checks]
If two function calls can share a return point, then they will also
get the same info table. Therefore, it's worth our effort to make
those opportunities appear as frequently as possible.
Here are a few examples of how it should work:
STG:
case f x of
True -> <True code -- including allocation>
False -> <False code>
Cmm:
r = call f(x) returns to L;
L:
if r & 7 >= 2 goto L1 else goto L2;
L1:
if Hp > HpLim then
r = gc(r);
goto L;
<True code -- including allocation>
L2:
<False code>
Note that the code following both the call to f(x) and the code to gc(r)
should be the same, which will allow the common blockifier to discover
that they are the same. Therefore, both function calls will return to the same
block, and they will use the same info table.
Here's an example of the Cmm code we want from a primOp.
The primOp doesn't produce an info table for us to reuse, but that's okay:
we should still generate the same code:
STG:
case f x of
0 -> <0-case code -- including allocation>
_ -> <default-case code>
Cmm:
r = a +# b;
L:
if r == 0 then goto L1 else goto L2;
L1:
if Hp > HpLim then
r = gc(r);
goto L;
<0-case code -- including allocation>
L2:
<default-case code>
-}
......@@ -117,7 +117,7 @@ emitForeignCall
-- only RTS procedures do this
-> FCode ()
emitForeignCall safety results target args _srt ret
| not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do
| not (playSafe safety) = do
let (caller_save, caller_load) = callerSaveVolatileRegs
updfr_off <- getUpdFrameOff
emit caller_save
......
......@@ -337,11 +337,10 @@ These are used in the following circumstances
entryHeapCheck :: LocalReg -- Function (closure environment)
-> Int -- Arity -- not same as length args b/c of voids
-> [LocalReg] -- Non-void args (empty for thunk)
-> C_SRT
-> FCode ()
-> FCode ()
entryHeapCheck fun arity args srt code
entryHeapCheck fun arity args code
= do updfr_sz <- getUpdFrameOff
heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive
where
......@@ -381,8 +380,8 @@ entryHeapCheck fun arity args srt code
gc_lbl_ptrs _ = Nothing