[Git][ghc/ghc][wip/T17978] 9 commits: WIP
Simon Jakobi
gitlab at gitlab.haskell.org
Sat Apr 4 02:40:23 UTC 2020
Simon Jakobi pushed to branch wip/T17978 at Glasgow Haskell Compiler / GHC
Commits:
cbe92c8a by Simon Jakobi at 2020-04-03T22:00:03+02:00
WIP
- - - - -
b3784f5a by Simon Jakobi at 2020-04-03T22:21:28+02:00
WIP: binding done
- - - - -
fb1e2246 by Simon Jakobi at 2020-04-03T22:52:34+02:00
WIP: rhs done
- - - - -
ed60a060 by Simon Jakobi at 2020-04-04T02:01:09+02:00
WIP: alt done, parts of expr
- - - - -
90064760 by Simon Jakobi at 2020-04-04T02:17:21+02:00
WIP: alts mostly
- - - - -
bb7c370e by Simon Jakobi at 2020-04-04T03:12:34+02:00
WIP: StgLet done
- - - - -
73f83372 by Simon Jakobi at 2020-04-04T03:20:06+02:00
WIP: expr done
- - - - -
a84b23aa by Simon Jakobi at 2020-04-04T04:30:23+02:00
WIP: args done
- - - - -
5b623bad by Simon Jakobi at 2020-04-04T04:39:41+02:00
Small refactoring
- - - - -
1 changed file:
- compiler/GHC/Stg/DepAnal.hs
Changes:
=====================================
compiler/GHC/Stg/DepAnal.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Types.Var.Set
import GHC.Types.Module (Module)
import Util
-import Data.Maybe ( mapMaybe )
+import Data.Maybe ( catMaybes )
import Data.Graph (SCC (..))
@@ -46,10 +46,6 @@ addLocals bndrs env
mkFreeVarSet :: Env -> [Id] -> DIdSet
mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)
-boundIds :: StgBinding -> [Id]
-boundIds (StgNonRec b _) = [b]
-boundIds (StgRec pairs) = map fst pairs
-
-- | Dependency analysis and free variable annotations on STG terms.
--
-- Dependencies of a binding are just free variables in the binding. This
@@ -73,102 +69,126 @@ annTopBindingsDeps this_mod bs = map top_bind bs
where
(bs', _dIdSet, fvs) = binding emptyEnv emptyDVarSet emptyVarSet bs
- binding :: Env -> DIdSet -> BVs -> StgBinding -> (CgStgBinding, DIdSet, FVs)
- binding = undefined rhs
-
- rhs :: Env -> BVs -> StgRhs -> (CgStgRhs, DIdSet, FVs)
- rhs = undefined args expr
-
- expr :: Env -> DIdSet -> BVs -> StgExpr -> (CgStgBinding, DIdSet, FVs)
- expr = undefined alts var expr
-
- alts :: Env -> BVs -> [StgAlt] -> ([CgStgAlt], DIdSet, FVs)
- alts = undefined expr
-
- args :: Env -> BVs -> [StgArg] -> (DIdSet, FVs)
- args = undefined var
-
- var :: Env -> BVs -> Var -> (DIdSet, FVs)
- var = undefined this_mod
-
-{-
binding :: Env -> DIdSet -> BVs -> StgBinding -> (CgStgBinding, DIdSet, FVs)
binding env body_fv bounds (StgNonRec bndr r) =
- (StgNonRec bndr r', fvs, rhs bounds r)
+ (StgNonRec bndr r', fvs, da_fvs)
where
-- See Note [Tracking local binders]
- (r', rhs_fvs) = rhsFV env r
+ (r', rhs_fvs, da_fvs) = rhs env bounds r
fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
-
- binding env body_fv bounds (StgRec pairs) =
- ( StgRec pairs'
- , fvs
- , unionVarSets $
- map (bind_non_rec (extendVarSetList bounds (map fst pairs))) pairs)
+ binding env body_fv bounds (StgRec bindings) =
+ ( StgRec (zip bndrs rhss')
+ , delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
+ , unionVarSets da_fvss
+ )
where
- -- See Note [Tracking local binders]
- bndrs = map fst pairs
- (rhss, rhs_fvss) = mapAndUnzip (rhsFV env . snd) pairs
- pairs' = zip bndrs rhss
- fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
-
- rhsFV :: Env -> StgRhs -> (CgStgRhs, DIdSet)
- rhsFV env (StgRhsClosure _ ccs uf bndrs body)
- = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+ (bndrs, rhss) = unzip bindings
+ bounds' = extendVarSetList bounds bndrs
+ (rhss', rhs_fvss, da_fvss) = mapAndUnzip3 (rhs env bounds') rhss
+
+ rhs :: Env -> BVs -> StgRhs -> (CgStgRhs, DIdSet, FVs)
+ rhs env bounds (StgRhsClosure _ ccs uf bndrs body) =
+ ( StgRhsClosure fvs ccs uf bndrs body'
+ , fvs
+ , da_fvs
+ )
where
- -- See Note [Tracking local binders]
- (body', body_fvs) = exprFV (addLocals bndrs env) body
+ (body', body_fvs, da_fvs) = expr (addLocals bndrs env) (extendVarSetList bounds bndrs) body
fvs = delDVarSetList body_fvs bndrs
- rhsFV env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, argsFV env as)
+ rhs env bounds (StgRhsCon ccs dc as) =
+ ( StgRhsCon ccs dc as
+ , fvs
+ , da_fvs
+ )
+ where
+ (fvs, da_fvs) = args env bounds as
- exprFV :: Env -> StgExpr -> (CgStgExpr, DIdSet)
- exprFV env = go
+ expr :: Env -> BVs -> StgExpr -> (CgStgExpr, DIdSet, FVs)
+ expr env = go
where
- go (StgApp occ as)
- = (StgApp occ as, unionDVarSet (argsFV env as) (mkFreeVarSet env [occ]))
- go (StgLit lit) = (StgLit lit, emptyDVarSet)
- go (StgConApp dc as tys) = (StgConApp dc as tys, argsFV env as)
- go (StgOpApp op as ty) = (StgOpApp op as ty, argsFV env as)
- go StgLam{} = pprPanic "StgFVs: StgLam" empty
- go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
+ go bounds (StgApp occ as) =
+ ( StgApp occ as
+ , unionDVarSet fvs (mkFreeVarSet env [occ])
+ , var bounds occ `unionVarSet` da_fvs
+ )
+ where
+ (fvs, da_fvs) = args env bounds as
+ go _ (StgLit lit) =
+ (StgLit lit, emptyDVarSet, emptyVarSet)
+ go bounds (StgConApp dc as tys) =
+ (StgConApp dc as tys, fvs, da_fvs)
+ where
+ (fvs, da_fvs) = args env bounds as
+ go bounds (StgOpApp op as ty) =
+ (StgOpApp op as ty, fvs, da_fvs)
where
- (scrut', scrut_fvs) = go scrut
+ (fvs, da_fvs) = args env bounds as
+ go _ lam at StgLam{} =
+ pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam)
+ go bounds (StgCase scrut bndr ty as) =
+ ( StgCase scrut' bndr ty alts'
+ , delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
+ , scrut_da_fvs `unionVarSet` alt_da_fvs
+ )
+ where
+ (scrut', scrut_fvs, scrut_da_fvs) = go bounds scrut
-- See Note [Tracking local binders]
- (alts', alt_fvss) = mapAndUnzip (altFV (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')
+ (alts', alt_fvs, alt_da_fvs) =
+ alts (addLocals [bndr] env) (extendVarSet bounds bndr) as
+ go bounds (StgLet ext bind body) =
+ go_bind bounds (StgLet ext) bind body
+ go bounds (StgLetNoEscape ext bind body) =
+ go_bind bounds (StgLetNoEscape ext) bind body
+ go bounds (StgTick tick e) =
+ (StgTick tick e', fvs', da_fvs)
where
- (e', fvs) = go e
+ (e', fvs, da_fvs) = go bounds e
fvs' = unionDVarSet (tickish tick) fvs
tickish (Breakpoint _ ids) = mkDVarSet ids
tickish _ = emptyDVarSet
-
- go_bind dc bind body = (dc bind' body', fvs)
+
+ go_bind bounds dc bind body =
+ ( dc bind' body'
+ , fvs
+ , da_bind_fvs `unionVarSet` da_body_fvs
+ )
where
-- See Note [Tracking local binders]
- env' = addLocals (boundIds bind) env
- (body', body_fvs) = exprFV env' body
- (bind', fvs, _) = binding env' body_fvs bind
+ binders = bindersOf bind
+ env' = addLocals binders env
+ (body', body_fvs, da_body_fvs) =
+ expr env' (extendVarSetList bounds binders) body
+ (bind', fvs, da_bind_fvs) = binding env' body_fvs bounds bind
- argsFV :: Env -> [StgArg] -> DIdSet
- argsFV env = mkFreeVarSet env . mapMaybe f
+ alts :: Env -> BVs -> [StgAlt] -> ([CgStgAlt], DIdSet, FVs)
+ alts env bounds as =
+ ( as'
+ , unionDVarSets alt_fvss
+ , unionVarSets alt_da_fvss
+ )
where
- f (StgVarArg occ) = Just occ
- f _ = Nothing
-
- bind_non_rec :: BVs -> (Id, StgRhs) -> FVs
- bind_non_rec bounds (_, r) =
- rhs bounds r
+ (as', alt_fvss, alt_da_fvss) = mapAndUnzip3 (alt env bounds) as
+
+ alt :: Env -> BVs -> StgAlt -> (CgStgAlt, DIdSet, FVs)
+ alt env bounds (con, bndrs, e) =
+ ( (con, bndrs, e')
+ , delDVarSetList rhs_fvs bndrs
+ , da_fvs
+ )
+ where
+ (e', rhs_fvs, da_fvs) = expr (addLocals bndrs env) (extendVarSetList bounds bndrs) e
- rhs :: BVs -> StgRhs -> FVs
- rhs bounds (StgRhsClosure _ _ _ as e) =
- expr (extendVarSetList bounds as) e
+ args :: Env -> BVs -> [StgArg] -> (DIdSet, FVs)
+ args env bounds as =
+ ( mkFreeVarSet env (catMaybes mIds)
+ , unionVarSets da_fvss
+ )
+ where
+ (mIds, da_fvss) = mapAndUnzip (arg bounds) as
- rhs bounds (StgRhsCon _ _ as) =
- args bounds as
+ arg :: BVs -> StgArg -> (Maybe Id, FVs)
+ arg bounds (StgVarArg v) = (Just v, var bounds v)
+ arg _ StgLitArg{} = (Nothing, emptyVarSet)
var :: BVs -> Var -> FVs
var bounds v
@@ -178,54 +198,6 @@ annTopBindingsDeps this_mod bs = map top_bind bs
| otherwise
= emptyVarSet
- arg :: BVs -> StgArg -> FVs
- arg bounds (StgVarArg v) = var bounds v
- arg _ StgLitArg{} = emptyVarSet
-
- args :: BVs -> [StgArg] -> FVs
- args bounds as = unionVarSets (map (arg bounds) as)
-
- expr :: BVs -> StgExpr -> FVs
- expr bounds (StgApp f as) =
- var bounds f `unionVarSet` args bounds as
-
- expr _ StgLit{} =
- emptyVarSet
-
- expr bounds (StgConApp _ as _) =
- args bounds as
- expr bounds (StgOpApp _ as _) =
- args bounds as
- expr _ lam at StgLam{} =
- pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam)
- expr bounds (StgCase scrut scrut_bndr _ as) =
- expr bounds scrut `unionVarSet`
- alts (extendVarSet bounds scrut_bndr) as
- expr bounds (StgLet _ bs e) =
- binding bounds bs `unionVarSet`
- expr (extendVarSetList bounds (bindersOf bs)) e
- expr bounds (StgLetNoEscape _ bs e) =
- binding bounds bs `unionVarSet`
- expr (extendVarSetList bounds (bindersOf bs)) e
-
- expr bounds (StgTick _ e) =
- expr bounds e
-
- alts :: BVs -> [StgAlt] -> FVs
- alts bounds = unionVarSets . map (alt bounds)
-
- alt :: BVs -> StgAlt -> FVs
- alt bounds (_, bndrs, e) =
- expr (extendVarSetList bounds bndrs) e
-
- altFV :: Env -> StgAlt -> (CgStgAlt, DIdSet)
- altFV env (con, bndrs, e) = ((con, bndrs, e'), fvs)
- where
- -- See Note [Tracking local binders]
- (e', rhs_fvs) = exprFV (addLocals bndrs env) e
- fvs = delDVarSetList rhs_fvs bndrs
--}
-
--------------------------------------------------------------------------------
-- * Dependency sorting
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7942a275a9b434b6851c0da2b3512fd6d5a85486...5b623bad6f0d4bbf88386cf119a49b09cf1aeca4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7942a275a9b434b6851c0da2b3512fd6d5a85486...5b623bad6f0d4bbf88386cf119a49b09cf1aeca4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200403/f5932720/attachment-0001.html>
More information about the ghc-commits
mailing list