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
-- 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] ->
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 =
-- 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
-- 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 _ _ _ ->
-- 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])
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
(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.
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
, 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
-- 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
-- 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
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
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
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
-- 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
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
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
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]
----------------------------------------------------------------
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
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)]
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
-- 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"
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.
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
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
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
| 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
-- 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
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 ()
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)
(_, _, 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) $
-- 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
-> 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
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
; 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*
-----------------------------------------
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)
; 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
:: 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 }
-- 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
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 }
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
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>
+-}
-- 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
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
gc_lbl_ptrs _ = Nothing
-altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a
-altHeapCheck regs srt code
+altHeapCheck :: [LocalReg] -> FCode a -> FCode a
+altHeapCheck regs code
= do updfr_sz <- getUpdFrameOff
heapCheck False (gc_call updfr_sz) code
where
| otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
- ; let srt = pprTrace "Urk! SRT for over-sat call"
- (ppr lbl) NoC_SRT
- -- XXX: what if rest_args contains static refs?
; withSequel (AssignTo [pap_id] True)
(emitCall Native target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
getSRTInfo (SRT off len bmp)
| len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
= do { id <- newUnique
- ; top_srt <- getSRTLabel
+ -- ; top_srt <- getSRTLabel
; let srt_desc_lbl = mkLargeSRTLabel id
-- JD: We're not constructing and emitting SRTs in the back end,
- -- which renders this code wrong (and it now names a now-non-existent label).
+ -- which renders this code wrong (it now names a now-non-existent label).
-- ; emitRODataLits srt_desc_lbl
-- ( cmmLabelOffW top_srt off
-- : mkWordCLit (fromIntegral len)
let zgraph = initUs_ us cvtm
us <- mkSplitUniqSupply 'S'
let topSRT = initUs_ us emptySRT
- (topSRT, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
+ (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
showPass dflags "Convert from Z back to Cmm"
Just loc ->
setAssigR (addToUFM (delFromUFM assig src) dst loc)
- -- we have elimianted this instruction
- freeregs <- getFreeRegsR
- assig <- getAssigR
+ -- we have eliminated this instruction
{-
+ freeregs <- getFreeRegsR
+ assig <- getAssigR
pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
-}
return (new_instrs, [])