never executed always true always false
1
2
3 module GHC.Stg.DepAnal (depSortStgPgm) where
4
5 import GHC.Prelude
6
7 import GHC.Stg.Syntax
8 import GHC.Types.Id
9 import GHC.Types.Name (Name, nameIsLocalOrFrom)
10 import GHC.Types.Name.Env
11 import GHC.Utils.Outputable
12 import GHC.Utils.Panic
13 import GHC.Types.Unique.Set (nonDetEltsUniqSet)
14 import GHC.Types.Var.Set
15 import GHC.Unit.Module (Module)
16
17 import Data.Graph (SCC (..))
18 import Data.Bifunctor (first)
19
20 --------------------------------------------------------------------------------
21 -- * Dependency analysis
22
23 -- | Set of bound variables
24 type BVs = VarSet
25
26 -- | Set of free variables
27 type FVs = VarSet
28
29 -- | Dependency analysis on STG terms.
30 --
31 -- Dependencies of a binding are just free variables in the binding. This
32 -- includes imported ids and ids in the current module. For recursive groups we
33 -- just return one set of free variables which is just the union of dependencies
34 -- of all bindings in the group.
35 --
36 -- Implementation: pass bound variables (BVs) to recursive calls, get free
37 -- variables (FVs) back. We ignore imported FVs as they do not change the
38 -- ordering but it improves performance.
39 --
40 annTopBindingsDeps :: Module -> [StgTopBinding] -> [(StgTopBinding, FVs)]
41 annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
42 where
43 top_bind :: StgTopBinding -> FVs
44 top_bind StgTopStringLit{} =
45 emptyVarSet
46
47 top_bind (StgTopLifted bs) =
48 binding emptyVarSet bs
49
50 binding :: BVs -> StgBinding -> FVs
51 binding bounds (StgNonRec _ r) =
52 rhs bounds r
53 binding bounds (StgRec bndrs) =
54 unionVarSets $
55 map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs
56
57 bind_non_rec :: BVs -> (Id, StgRhs) -> FVs
58 bind_non_rec bounds (_, r) =
59 rhs bounds r
60
61 rhs :: BVs -> StgRhs -> FVs
62 rhs bounds (StgRhsClosure _ _ _ as e) =
63 expr (extendVarSetList bounds as) e
64
65 rhs bounds (StgRhsCon _ _ _ _ as) =
66 args bounds as
67
68 var :: BVs -> Var -> FVs
69 var bounds v
70 | not (elemVarSet v bounds)
71 , nameIsLocalOrFrom this_mod (idName v)
72 = unitVarSet v
73 | otherwise
74 = emptyVarSet
75
76 arg :: BVs -> StgArg -> FVs
77 arg bounds (StgVarArg v) = var bounds v
78 arg _ StgLitArg{} = emptyVarSet
79
80 args :: BVs -> [StgArg] -> FVs
81 args bounds as = unionVarSets (map (arg bounds) as)
82
83 expr :: BVs -> StgExpr -> FVs
84 expr bounds (StgApp f as) =
85 var bounds f `unionVarSet` args bounds as
86
87 expr _ StgLit{} =
88 emptyVarSet
89
90 expr bounds (StgConApp _ _ as _) =
91 args bounds as
92 expr bounds (StgOpApp _ as _) =
93 args bounds as
94 expr bounds (StgCase scrut scrut_bndr _ as) =
95 expr bounds scrut `unionVarSet`
96 alts (extendVarSet bounds scrut_bndr) as
97 expr bounds (StgLet _ bs e) =
98 binding bounds bs `unionVarSet`
99 expr (extendVarSetList bounds (bindersOf bs)) e
100 expr bounds (StgLetNoEscape _ bs e) =
101 binding bounds bs `unionVarSet`
102 expr (extendVarSetList bounds (bindersOf bs)) e
103
104 expr bounds (StgTick _ e) =
105 expr bounds e
106
107 alts :: BVs -> [StgAlt] -> FVs
108 alts bounds = unionVarSets . map (alt bounds)
109
110 alt :: BVs -> StgAlt -> FVs
111 alt bounds (_, bndrs, e) =
112 expr (extendVarSetList bounds bndrs) e
113
114 --------------------------------------------------------------------------------
115 -- * Dependency sorting
116
117 -- | Dependency sort a STG program so that dependencies come before uses.
118 depSortStgPgm :: Module -> [StgTopBinding] -> [StgTopBinding]
119 depSortStgPgm this_mod =
120 {-# SCC "STG.depSort" #-}
121 map fst . depSort . annTopBindingsDeps this_mod
122
123 -- | Sort free-variable-annotated STG bindings so that dependencies come before
124 -- uses.
125 depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)]
126 depSort = concatMap get_binds . depAnal defs uses
127 where
128 uses, defs :: (StgTopBinding, FVs) -> [Name]
129
130 -- TODO (osa): I'm unhappy about two things in this code:
131 --
132 -- * Why do we need Name instead of Id for uses and dependencies?
133 -- * Why do we need a [Name] instead of `Set Name`? Surely depAnal
134 -- doesn't need any ordering.
135
136 uses (StgTopStringLit{}, _) = []
137 uses (StgTopLifted{}, fvs) = map idName (nonDetEltsUniqSet fvs)
138
139 defs (bind, _) = map idName (bindersOfTop bind)
140
141 get_binds (AcyclicSCC bind) =
142 [bind]
143 get_binds (CyclicSCC binds) =
144 pprPanic "depSortStgBinds"
145 (text "Found cyclic SCC:"
146 $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))