| ... |
... |
@@ -10,16 +10,18 @@ import GHC.Prelude hiding ( head, init, last ) |
|
10
|
10
|
import GHC.Core
|
|
11
|
11
|
import GHC.Core.FVs
|
|
12
|
12
|
import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit)
|
|
|
13
|
+import GHC.Core.Stats (coreBindsSize)
|
|
13
|
14
|
|
|
14
|
15
|
import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq)
|
|
15
|
16
|
import GHC.Data.Maybe (orElse)
|
|
16
|
17
|
|
|
17
|
18
|
import GHC.Types.Unique.Set
|
|
18
|
|
-import GHC.Types.Name (isExternalName, nameModule)
|
|
19
|
|
-import GHC.Types.Id (realIdUnfolding)
|
|
|
19
|
+import GHC.Types.Name (Name, isExternalName, nameModule)
|
|
|
20
|
+import GHC.Types.Id (isDFunId, realIdUnfolding)
|
|
20
|
21
|
import GHC.Types.Var.Set
|
|
21
|
22
|
import GHC.Types.Var.Env
|
|
22
|
23
|
import GHC.Types.Var
|
|
|
24
|
+import GHC.Types.Name.Env
|
|
23
|
25
|
|
|
24
|
26
|
import GHC.Utils.Outputable
|
|
25
|
27
|
import GHC.Utils.Panic
|
| ... |
... |
@@ -100,25 +102,40 @@ bindSplitFreeVars :: VarSet -> CoreBind -> VarSet |
|
100
|
102
|
bindSplitFreeVars local_top_bndrs bind =
|
|
101
|
103
|
close_over_imported_unfoldings (bindMentionedVars bind `unionVarSet` bindBndrInfoVars bind)
|
|
102
|
104
|
where
|
|
|
105
|
+ local_name_env :: NameEnv Var
|
|
|
106
|
+ local_name_env = mkNameEnv [ (varName v, v) | v <- nonDetEltsUniqSet local_top_bndrs ]
|
|
|
107
|
+
|
|
103
|
108
|
close_over_imported_unfoldings fvs = go emptyVarSet fvs
|
|
104
|
109
|
|
|
105
|
110
|
go !seen !fvs =
|
|
106
|
111
|
case pick_new_import (fvs `minusVarSet` seen) of
|
|
107
|
112
|
Nothing -> fvs
|
|
108
|
113
|
Just v ->
|
|
109
|
|
- let unfolding_fvs = unfoldingRefs v
|
|
|
114
|
+ let unfolding_fvs = localizeLocalRefs (unfoldingRefs v)
|
|
110
|
115
|
local_unfolding_fvs = unfolding_fvs `intersectVarSet` local_top_bndrs
|
|
111
|
116
|
in go (extendVarSet seen v) (fvs `unionVarSet` local_unfolding_fvs `unionVarSet` unfolding_fvs)
|
|
112
|
117
|
|
|
113
|
118
|
pick_new_import vars =
|
|
114
|
119
|
find pickable (nonDetEltsUniqSet vars)
|
|
115
|
120
|
|
|
116
|
|
- pickable v = isId v && not (v `elemVarSet` local_top_bndrs)
|
|
|
121
|
+ pickable v = isId v && isDFunId v && not (v `elemVarSet` local_top_bndrs)
|
|
117
|
122
|
|
|
118
|
123
|
unfoldingRefs v =
|
|
119
|
|
- case maybeUnfoldingTemplate (realIdUnfolding v) of
|
|
120
|
|
- Just rhs -> exprSomeFreeVars (const True) rhs
|
|
121
|
|
- Nothing -> emptyVarSet
|
|
|
124
|
+ case realIdUnfolding v of
|
|
|
125
|
+ BootUnfolding -> emptyVarSet
|
|
|
126
|
+ unf ->
|
|
|
127
|
+ case maybeUnfoldingTemplate unf of
|
|
|
128
|
+ Just rhs -> exprSomeFreeVars (const True) rhs
|
|
|
129
|
+ Nothing -> emptyVarSet
|
|
|
130
|
+
|
|
|
131
|
+ localizeLocalRefs :: VarSet -> VarSet
|
|
|
132
|
+ localizeLocalRefs vars = mkVarSet (map localizeVar (nonDetEltsUniqSet vars))
|
|
|
133
|
+
|
|
|
134
|
+ localizeVar :: Var -> Var
|
|
|
135
|
+ localizeVar v =
|
|
|
136
|
+ case lookupNameEnv local_name_env (varName v) of
|
|
|
137
|
+ Just local_v -> local_v
|
|
|
138
|
+ Nothing -> v
|
|
122
|
139
|
|
|
123
|
140
|
bindMentionedVars :: CoreBind -> VarSet
|
|
124
|
141
|
bindMentionedVars (NonRec _ rhs) = exprSomeFreeVars (const True) rhs
|
| ... |
... |
@@ -219,8 +236,10 @@ pprVarWithModule v |
|
219
|
236
|
splitCompUnit :: Module -> [CoreRule] -> CoreCompUnit -> ([CoreCompUnit], [CoreRule])
|
|
220
|
237
|
splitCompUnit this_module imp_rules unit
|
|
221
|
238
|
= let comp_units = map mk_comp_unit components_with_rules
|
|
222
|
|
- in checkNameClashes comp_units `seq`
|
|
223
|
|
- (comp_units, rules_for_imps ++ rules_without_component)
|
|
|
239
|
+ result = (comp_units, rules_for_imps ++ rules_without_component)
|
|
|
240
|
+ in -- pprTrace "CoreSplitTrace" (pprSplitTrace comp_units) $
|
|
|
241
|
+ checkNameClashes comp_units `seq`
|
|
|
242
|
+ result
|
|
224
|
243
|
where
|
|
225
|
244
|
CoreCompUnit occ_binds unit_rules =
|
|
226
|
245
|
occurAnalyseCompUnit this_module (const True) (const True) imp_rules unit
|
| ... |
... |
@@ -269,3 +288,24 @@ checkNameClashes comp_units |
|
269
|
288
|
go seen (b:bs)
|
|
270
|
289
|
| b `elemVarSet` seen = b : go seen bs
|
|
271
|
290
|
| otherwise = go (extendVarSet seen b) bs
|
|
|
291
|
+
|
|
|
292
|
+pprSplitTrace :: [CoreCompUnit] -> SDoc
|
|
|
293
|
+pprSplitTrace comp_units =
|
|
|
294
|
+ text (show (length comp_units))
|
|
|
295
|
+ <+> text "Unit; CoreSizes:"
|
|
|
296
|
+ <+> pprIntList sizes
|
|
|
297
|
+ <> semi
|
|
|
298
|
+ <+> text "RelativeSize:"
|
|
|
299
|
+ <+> pprPercentList rel_sizes
|
|
|
300
|
+ where
|
|
|
301
|
+ sizes = map (coreBindsSize . coreCompUnitBinds) comp_units
|
|
|
302
|
+ total_size = sum sizes
|
|
|
303
|
+ rel_sizes
|
|
|
304
|
+ | total_size == 0 = replicate (length sizes) 0
|
|
|
305
|
+ | otherwise = map (\sz -> (100 * sz) `div` total_size) sizes
|
|
|
306
|
+
|
|
|
307
|
+pprIntList :: [Int] -> SDoc
|
|
|
308
|
+pprIntList xs = brackets (hcat (punctuate comma (map int xs)))
|
|
|
309
|
+
|
|
|
310
|
+pprPercentList :: [Int] -> SDoc
|
|
|
311
|
+pprPercentList xs = brackets (hcat (punctuate comma [ int x <> char '%' | x <- xs ])) |