Commit d1dfe190 authored by Alex D's avatar Alex D 🍄

T16064 Heap checks WIP

parent e122ba33
......@@ -47,6 +47,7 @@ import Maybes
import Util
import FastString
import Outputable
import StgFVs
import Control.Monad (unless,void)
import Control.Arrow (first)
......@@ -310,9 +311,12 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
; tmp_reg <- bindArgToReg (NonVoid bndr)
; emitAssign (CmmLocal tmp_reg)
(tagToClosure dflags tycon tag_expr) }
; let altsWithFlag :: [(Bool, CgStgAlt)]
altsWithFlag =
map (\alt@(_altCon, _binders, expr) -> (hasLocalBinders expr, alt))
alts
; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)
(NonVoid bndr) alts
(NonVoid bndr) altsWithFlag
-- See Note [GC for conditionals]
; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)
; return AssignedDirectly
......@@ -437,7 +441,11 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
(idInfoToAmode v_info)
-- Add bndr to the environment
; _ <- bindArgToReg (NonVoid bndr)
; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
; let altsWithFlag :: [(Bool, CgStgAlt)]
altsWithFlag =
map (\alt@(_altCon, _binders, expr) -> (hasLocalBinders expr, alt))
alts
; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type altsWithFlag }
where
reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr)
......@@ -494,6 +502,11 @@ cgCase scrut bndr alt_type alts
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
alt_regs = map (idToReg dflags) ret_bndrs
; simple_scrut <- isSimpleScrut scrut alt_type
--
; let altsWithFlag :: [(Bool, CgStgAlt)]
altsWithFlag =
map (\alt@(_altCon, _binders, expr) -> (hasLocalBinders expr, alt))
alts
; let do_gc | is_cmp_op scrut = False -- See Note [GC for conditionals]
| not simple_scrut = True
| isSingleton alts = False
......@@ -508,7 +521,7 @@ cgCase scrut bndr alt_type alts
; ret_kind <- withSequel sequel (cgExpr scrut)
; restoreCurrentCostCentre mb_cc
; _ <- bindArgsToRegs ret_bndrs
; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts
; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type altsWithFlag
}
where
is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
......@@ -601,14 +614,14 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
-- MultiValAlt has only one alternative
-------------------------------------
cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [(Bool, CgStgAlt)]
-> FCode ReturnKind
-- At this point the result of the case are in the binders
cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
= maybeAltHeapCheck gc_plan (cgExpr rhs)
cgAlts gc_plan _bndr PolyAlt [(allocate, (_, _, rhs))]
= maybeAltHeapCheck allocate gc_plan (cgExpr rhs)
cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]
= maybeAltHeapCheck gc_plan (cgExpr rhs)
cgAlts gc_plan _bndr (MultiValAlt _) [(allocate, (_, _, rhs))]
= maybeAltHeapCheck allocate gc_plan (cgExpr rhs)
-- Here bndrs are *already* in scope, so don't rebind them
cgAlts gc_plan bndr (PrimAlt _) alts
......@@ -676,7 +689,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
-- goto L1
-------------------
cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [(Bool, CgStgAlt)]
-> FCode ( Maybe CmmAGraphScoped
, [(ConTagZ, CmmAGraphScoped)] )
cgAlgAltRhss gc_plan bndr alts
......@@ -696,16 +709,16 @@ cgAlgAltRhss gc_plan bndr alts
-------------------
cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [(Bool, CgStgAlt)]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss gc_plan bndr alts = do
dflags <- getDynFlags
let
base_reg = idToReg dflags bndr
cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
cg_alt (con, bndrs, rhs)
= getCodeScoped $
maybeAltHeapCheck gc_plan $
cg_alt :: (Bool, CgStgAlt) -> FCode (AltCon, CmmAGraphScoped)
cg_alt (allocate, (con, bndrs, rhs))
= getCodeScoped $
maybeAltHeapCheck allocate gc_plan $
do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)
-- alt binders are always non-void,
-- see Note [Post-unarisation invariants] in UnariseStg
......@@ -713,11 +726,16 @@ cgAltRhss gc_plan bndr alts = do
; return con }
forkAlts (map cg_alt alts)
maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (NoGcInAlts,_) code = code
maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =
maybeAltHeapCheck :: Bool -> (GcPlan,ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck alloc gc_plan code
| not alloc = trace "NO ALLOC " code
| otherwise = trace "ALLOC " $ maybe_alt_heap_check gc_plan code
maybe_alt_heap_check :: (GcPlan,ReturnKind) -> FCode a -> FCode a
maybe_alt_heap_check (NoGcInAlts,_) code = code
maybe_alt_heap_check (GcInAlts regs, AssignedDirectly) code =
altHeapCheck regs code
maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
maybe_alt_heap_check (GcInAlts regs, ReturnedTo lret off) code =
altHeapCheckReturnsTo regs lret off code
-----------------------------------------------------------------------------
......
-- | Free variable analysis on STG terms.
module StgFVs (
annTopBindingsFreeVars,
annBindingFreeVars
annBindingFreeVars,
hasLocalBinders
) where
import GhcPrelude
......@@ -12,6 +13,7 @@ import VarSet
import CoreSyn ( Tickish(Breakpoint) )
import Outputable
import Util
import UniqDSet
import Data.Maybe ( mapMaybe )
......@@ -128,3 +130,89 @@ alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
-- See Note [Tracking local binders]
(e', rhs_fvs) = expr (addLocals bndrs env) e
fvs = delDVarSetList rhs_fvs bndrs
hasLocalBinders :: CgStgExpr -> Bool
hasLocalBinders stgExpr =
let
(_, fvs) = expr' emptyEnv (pprTraceIt "\nchecking local binders for" stgExpr)
in
not (isEmptyUniqDSet (pprTraceIt "fvs:" fvs))
expr' :: Env -> CgStgExpr -> (CgStgExpr, DIdSet)
expr' env = go
where
go (StgApp occ as)
= (StgApp occ as, unionDVarSet (args' env as) (mkFreeVarSet env [occ]))
go (StgLit lit) = (StgLit lit, emptyDVarSet)
go (StgConApp dc as tys) = (StgConApp dc as tys, args' env as)
go (StgOpApp op as ty) = (StgOpApp op as ty, args' env as)
go StgLam{} = pprPanic "StgFVs: StgLam" empty
go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
where
(scrut', scrut_fvs) = go scrut
-- See Note [Tacking local binders]
(alts', alt_fvss) = mapAndUnzip (alt' (addLocals [bndr] env)) alts
alt_fvs = unionDVarSets alt_fvss
fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
go (StgLet ext bind body) = go_bind (StgLet ext) bind body
go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
go (StgTick tick e) = (StgTick tick e', fvs')
where
(e', fvs) = go e
fvs' = unionDVarSet (tickish tick) fvs
tickish (Breakpoint _ ids) = mkDVarSet ids
tickish _ = emptyDVarSet
go_bind dc bind body = (dc bind' body', fvs)
where
-- See Note [Tacking local binders]
env' = addLocals (boundIds' bind) env
(body', body_fvs) = expr' env' body
(bind', fvs) = binding' env' body_fvs bind
doesAllocate :: CgStgExpr -> Bool
doesAllocate = go
where
go (StgLet _ _ _) = True
go (StgLetNoEscape _ _ _) = True
go _ = False
rhs' :: Env -> CgStgRhs -> (CgStgRhs, DIdSet)
rhs' env (StgRhsClosure _ ccs uf bndrs body)
= (StgRhsClosure fvs ccs uf bndrs body', fvs)
where
-- See Note [Tacking local binders]
(body', body_fvs) = expr' (addLocals bndrs env) body
fvs = delDVarSetList body_fvs bndrs
rhs' env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args' env as)
alt' :: Env -> CgStgAlt -> (CgStgAlt, DIdSet)
alt' env (con, bndrs, e) = ((con, bndrs, e'), fvs)
where
-- See Note [Tacking local binders]
(e', rhs_fvs) = expr' (addLocals bndrs env) e
fvs = delDVarSetList rhs_fvs bndrs
args' :: Env -> [StgArg] -> DIdSet
args' env = mkFreeVarSet env . mapMaybe f
where
f (StgVarArg occ) = Just occ
f _ = Nothing
binding' :: Env -> DIdSet -> CgStgBinding -> (CgStgBinding, DIdSet)
binding' env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
where
-- See Note [Tacking local binders]
(r', rhs_fvs) = rhs' env r
fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
binding' env body_fv (StgRec pairs) = (StgRec pairs', fvs)
where
-- See Note [Tacking local binders]
bndrs = map fst pairs
(rhss, rhs_fvss) = mapAndUnzip (rhs' env . snd) pairs
pairs' = zip bndrs rhss
fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
boundIds' :: CgStgBinding -> [Id]
boundIds' (StgNonRec b _) = [b]
boundIds' (StgRec pairs) = map fst pairs
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment