... |
... |
@@ -39,7 +39,6 @@ import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) |
39
|
39
|
import GHC.Core.Coercion
|
40
|
40
|
import GHC.Core.Predicate ( isDictId )
|
41
|
41
|
import GHC.Core.Type
|
42
|
|
-import GHC.Core.TyCo.Rep
|
43
|
42
|
import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
|
44
|
43
|
|
45
|
44
|
import GHC.Data.Maybe( orElse )
|
... |
... |
@@ -50,6 +49,7 @@ import GHC.Types.Unique |
50
|
49
|
import GHC.Types.Unique.FM
|
51
|
50
|
import GHC.Types.Unique.Set
|
52
|
51
|
import GHC.Types.Id
|
|
52
|
+import GHC.Types.Name( isExternalName )
|
53
|
53
|
import GHC.Types.Id.Info
|
54
|
54
|
import GHC.Types.Basic
|
55
|
55
|
import GHC.Types.Tickish
|
... |
... |
@@ -65,6 +65,8 @@ import GHC.Utils.Misc |
65
|
65
|
import GHC.Builtin.Names( runRWKey )
|
66
|
66
|
import GHC.Unit.Module( Module )
|
67
|
67
|
|
|
68
|
+import qualified Data.Semigroup as S( Semigroup(..) )
|
|
69
|
+import qualified Data.Monoid as S( Monoid(..) )
|
68
|
70
|
import Data.List (mapAccumL)
|
69
|
71
|
import Data.List.NonEmpty (NonEmpty (..))
|
70
|
72
|
|
... |
... |
@@ -100,18 +102,15 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds |
100
|
102
|
init_env = initOccEnv { occ_rule_act = active_rule
|
101
|
103
|
, occ_unf_act = active_unf }
|
102
|
104
|
|
103
|
|
- WUD final_usage occ_anald_binds = go binds init_env
|
104
|
|
- WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel
|
105
|
|
- imp_rule_edges
|
106
|
|
- (flattenBinds binds)
|
107
|
|
- initial_uds
|
|
105
|
+ WUD final_usage occ_anald_binds = go binds init_env
|
|
106
|
+ WUD _ occ_anald_glommed_binds = go (glomValBinds binds) init_env
|
108
|
107
|
-- It's crucial to re-analyse the glommed-together bindings
|
109
|
108
|
-- so that we establish the right loop breakers. Otherwise
|
110
|
109
|
-- we can easily create an infinite loop (#9583 is an example)
|
111
|
110
|
--
|
112
|
|
- -- Also crucial to re-analyse the /original/ bindings
|
113
|
|
- -- in case the first pass accidentally discarded as dead code
|
114
|
|
- -- a binding that was actually needed (albeit before its
|
|
111
|
+ -- Also crucial to re-analyse the /original/ bindings, not the
|
|
112
|
+ -- occ_anald_binds, in case the first pass accidentally discarded as
|
|
113
|
+ -- dead code a binding that was actually needed (albeit before its
|
115
|
114
|
-- definition site). #17724 threw this up.
|
116
|
115
|
|
117
|
116
|
initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)
|
... |
... |
@@ -971,16 +970,32 @@ occAnalBind |
971
|
970
|
-> WithUsageDetails r -- Of the whole let(rec)
|
972
|
971
|
|
973
|
972
|
occAnalBind env lvl ire (Rec pairs) thing_inside combine
|
974
|
|
- = addInScopeList env (map fst pairs) $ \env ->
|
|
973
|
+ = addInScope env (map fst pairs) $ \env ->
|
975
|
974
|
let WUD body_uds body' = thing_inside env
|
976
|
975
|
WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
|
977
|
976
|
in WUD bind_uds (combine binds' body')
|
978
|
977
|
|
979
|
|
-occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
|
980
|
|
- | isTyVar bndr -- A type let; we don't gather usage info
|
981
|
|
- = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside
|
982
|
|
- in WUD body_uds (combine [NonRec bndr rhs] res)
|
|
978
|
+occAnalBind !env _lvl _ire (NonRec bndr rhs) thing_inside combine
|
|
979
|
+ | isTyCoVar bndr -- A type/coercion let
|
|
980
|
+ = let !(WUD body_uds (occ,res))
|
|
981
|
+ = addInScopeOne env bndr $ \env_body ->
|
|
982
|
+ let !(WUD inner_uds inner_res) = thing_inside env_body
|
|
983
|
+ !tyco_occ = lookupTyCoOcc inner_uds bndr
|
|
984
|
+ in (WUD inner_uds (tyco_occ, inner_res))
|
|
985
|
+
|
|
986
|
+ rhs_tyco_occs = case rhs of
|
|
987
|
+ Type ty -> occAnalTy ty
|
|
988
|
+ Coercion co -> occAnalCo co
|
|
989
|
+ _ -> pprPanic "occAnalBind" (ppr (NonRec bndr rhs))
|
|
990
|
+ in
|
|
991
|
+ case occ of
|
|
992
|
+ TyCoDead -> WUD body_uds res
|
|
993
|
+ _ -> WUD (body_uds `addTyCoOccs` rhs_tyco_occs)
|
|
994
|
+ (combine [NonRec bndr' rhs] res)
|
|
995
|
+ where
|
|
996
|
+ bndr' = tagTyCoBinder occ bndr
|
983
|
997
|
|
|
998
|
+occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
|
984
|
999
|
-- /Existing/ non-recursive join points
|
985
|
1000
|
-- See Note [Occurrence analysis for join points]
|
986
|
1001
|
| mb_join@(JoinPoint {}) <- idJoinPointHood bndr
|
... |
... |
@@ -1134,19 +1149,13 @@ occAnalRec :: OccEnv -> TopLevelFlag |
1134
|
1149
|
-> WithUsageDetails [CoreBind]
|
1135
|
1150
|
|
1136
|
1151
|
-- The NonRec case is just like a Let (NonRec ...) above
|
|
1152
|
+-- except that type variables can't occur
|
1137
|
1153
|
occAnalRec !_ lvl
|
1138
|
1154
|
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
|
1139
|
1155
|
(WUD body_uds binds)
|
1140
|
|
- -- Currently we don't gather occ-info for tyvars,
|
1141
|
|
- -- so we never discard dead bindings -- Need to fix this
|
1142
|
|
- | isTyVar bndr
|
1143
|
|
- = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
|
1144
|
|
- !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
|
1145
|
|
- !bndr' = tagged_bndr
|
1146
|
|
- in WUD (body_uds `andUDs` rhs_uds')
|
1147
|
|
- (NonRec bndr' rhs' : binds)
|
1148
|
|
-
|
1149
|
|
- | isDeadOcc occ -- Check for dead code: see Note [Dead code]
|
|
1156
|
+ | assertPpr (not (isTyVar bndr)) (ppr bndr) $
|
|
1157
|
+ -- Rec blocks have no TyVar bindings in them
|
|
1158
|
+ isDeadOcc occ -- Check for dead code: see Note [Dead code]
|
1150
|
1159
|
= WUD body_uds binds
|
1151
|
1160
|
|
1152
|
1161
|
| otherwise
|
... |
... |
@@ -1705,7 +1714,7 @@ rank (r, _, _) = r |
1705
|
1714
|
makeNode :: OccEnv -> ImpRuleEdges -> VarSet
|
1706
|
1715
|
-> (Var, CoreExpr) -> LetrecNode
|
1707
|
1716
|
-- See Note [Recursive bindings: the grand plan]
|
1708
|
|
-makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
|
|
1717
|
+makeNode !_env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
|
1709
|
1718
|
= -- This is a type binding, e.g. let @x = Maybe Int in ...
|
1710
|
1719
|
assert (isTyVar bndr) $
|
1711
|
1720
|
DigraphNode { node_payload = details
|
... |
... |
@@ -1719,8 +1728,7 @@ makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) |
1719
|
1728
|
, nd_weak_fvs = emptyVarSet
|
1720
|
1729
|
, nd_active_rule_fvs = emptyVarSet }
|
1721
|
1730
|
|
1722
|
|
- rhs_env = setNonTailCtxt OccRhs env
|
1723
|
|
- rhs_uds = occAnalTy rhs_env rhs_ty
|
|
1731
|
+ rhs_uds = mkTyCoUDs (occAnalTy rhs_ty)
|
1724
|
1732
|
rhs_fvs = udFreeVars bndr_set rhs_uds
|
1725
|
1733
|
|
1726
|
1734
|
makeNode !env imp_rule_edges bndr_set (bndr, rhs)
|
... |
... |
@@ -2229,9 +2237,9 @@ occ_anal_lam_tail env (Cast expr co) |
2229
|
2237
|
= let WUD expr_uds expr' = occ_anal_lam_tail env expr
|
2230
|
2238
|
|
2231
|
2239
|
-- co_uds: see Note [Gather occurrences of coercion variables]
|
2232
|
|
- co_uds = occAnalCo env co
|
|
2240
|
+ co_uds = occAnalCo co
|
2233
|
2241
|
|
2234
|
|
- usage1 = expr_uds `andUDs` co_uds
|
|
2242
|
+ usage1 = expr_uds `addTyCoOccs` co_uds
|
2235
|
2243
|
|
2236
|
2244
|
-- usage2: see Note [Occ-anal and cast worker/wrapper]
|
2237
|
2245
|
usage2 = case expr of
|
... |
... |
@@ -2436,14 +2444,54 @@ float ==> |
2436
|
2444
|
This is worse than the slow cascade, so we only want to say "certainly_inline"
|
2437
|
2445
|
if it really is certain. Look at the note with preInlineUnconditionally
|
2438
|
2446
|
for the various clauses. See #24582 for an example of the two getting out of sync.
|
|
2447
|
+-}
|
|
2448
|
+
|
|
2449
|
+{- *********************************************************************
|
|
2450
|
+* *
|
|
2451
|
+ Types
|
|
2452
|
+* *
|
|
2453
|
+********************************************************************* -}
|
2439
|
2454
|
|
|
2455
|
+newtype TyCoOccs = TyCoOccs { get_tyco_occs :: TyCoOccEnv }
|
2440
|
2456
|
|
2441
|
|
-************************************************************************
|
|
2457
|
+instance S.Semigroup TyCoOccs where
|
|
2458
|
+ (TyCoOccs o1) <> (TyCoOccs o2) = TyCoOccs (plusTyCoOccEnv o1 o2)
|
|
2459
|
+
|
|
2460
|
+instance S.Monoid TyCoOccs where
|
|
2461
|
+ mempty = TyCoOccs emptyVarEnv
|
|
2462
|
+
|
|
2463
|
+occTyCoFolder :: TyCoFolder TyCoVarSet TyCoOccs
|
|
2464
|
+occTyCoFolder
|
|
2465
|
+ = TyCoFolder { tcf_view = \_ -> Nothing -- No need to expand synonyms
|
|
2466
|
+ , tcf_tyvar = do_var
|
|
2467
|
+ , tcf_covar = do_var
|
|
2468
|
+ , tcf_hole = \_ h -> pprPanic "occTyCoFolder:hole" (ppr h)
|
|
2469
|
+ , tcf_tycobinder = do_binder }
|
|
2470
|
+ where
|
|
2471
|
+ do_var :: TyCoVarSet -> TyCoVar -> TyCoOccs
|
|
2472
|
+ do_var locals tcv
|
|
2473
|
+ | tcv `elemVarSet` locals = mempty
|
|
2474
|
+ | isExternalName (varName tcv) = mempty -- TyVars from other modules
|
|
2475
|
+ | otherwise = TyCoOccs (unitVarEnv tcv TyCoOne)
|
|
2476
|
+
|
|
2477
|
+ do_binder :: TyCoVarSet -> TyCoVar -> ForAllTyFlag -> TyCoVarSet
|
|
2478
|
+ do_binder locals tcv _ = extendVarSet locals tcv
|
|
2479
|
+
|
|
2480
|
+occAnalTy :: Type -> TyCoOccEnv
|
|
2481
|
+occAnalCo :: Coercion -> TyCoOccEnv
|
|
2482
|
+occAnalTy ty = get_tyco_occs (occ_anal_ty ty)
|
|
2483
|
+occAnalCo co = get_tyco_occs (occ_anal_co co)
|
|
2484
|
+
|
|
2485
|
+occ_anal_ty :: Type -> TyCoOccs
|
|
2486
|
+occ_anal_co :: Coercion -> TyCoOccs
|
|
2487
|
+(occ_anal_ty, _, occ_anal_co, _) = foldTyCo occTyCoFolder emptyVarSet
|
|
2488
|
+-- No need to return a modified type, unlike expressions
|
|
2489
|
+
|
|
2490
|
+{- *********************************************************************
|
2442
|
2491
|
* *
|
2443
|
2492
|
Expressions
|
2444
|
2493
|
* *
|
2445
|
|
-************************************************************************
|
2446
|
|
--}
|
|
2494
|
+********************************************************************* -}
|
2447
|
2495
|
|
2448
|
2496
|
occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
|
2449
|
2497
|
occAnalList !_ [] = WUD emptyDetails []
|
... |
... |
@@ -2452,50 +2500,6 @@ occAnalList env (e:es) = let |
2452
|
2500
|
(WUD uds2 es') = occAnalList env es
|
2453
|
2501
|
in WUD (uds1 `andUDs` uds2) (e' : es')
|
2454
|
2502
|
|
2455
|
|
-occAnalTys :: OccEnv -> [Type] -> UsageDetails
|
2456
|
|
-occAnalTys env tys = foldr (andUDs . occAnalTy env) emptyDetails tys
|
2457
|
|
-
|
2458
|
|
-occAnalTy :: OccEnv -> Type -> UsageDetails
|
2459
|
|
--- No need to return a modified type, unlike expressions
|
2460
|
|
-occAnalTy env (TyVarTy tv) = mkOneTyVarOcc env tv
|
2461
|
|
-occAnalTy _ (LitTy {}) = emptyDetails
|
2462
|
|
-occAnalTy env (AppTy t1 t2) = occAnalTy env t1 `andUDs` occAnalTy env t2
|
2463
|
|
-occAnalTy env (CastTy ty co) = occAnalTy env ty `andUDs` occAnalCo env co
|
2464
|
|
-occAnalTy env (CoercionTy co) = occAnalCo env co
|
2465
|
|
-occAnalTy env (TyConApp _ tys) = occAnalTys env tys
|
2466
|
|
-occAnalTy env (ForAllTy (Bndr tv _) ty) = delBndrsFromUDs [tv] (occAnalTy env ty)
|
2467
|
|
-occAnalTy env (FunTy { ft_mult = w, ft_arg = arg, ft_res = res })
|
2468
|
|
- = occAnalTy env w `andUDs` occAnalTy env arg `andUDs` occAnalTy env res
|
2469
|
|
-
|
2470
|
|
-occAnalCos :: OccEnv -> [Coercion] -> UsageDetails
|
2471
|
|
-occAnalCos env cos = foldr (andUDs . occAnalCo env) emptyDetails cos
|
2472
|
|
-
|
2473
|
|
-occAnalMCo :: OccEnv -> MCoercion -> UsageDetails
|
2474
|
|
-occAnalMCo _ MRefl = emptyDetails
|
2475
|
|
-occAnalMCo env (MCo co) = occAnalCo env co
|
2476
|
|
-
|
2477
|
|
-occAnalCo :: OccEnv -> Coercion -> UsageDetails
|
2478
|
|
-occAnalCo !env (Refl ty) = occAnalTy env ty
|
2479
|
|
-occAnalCo !env (GRefl _ ty mco) = occAnalTy env ty `andUDs` occAnalMCo env mco
|
2480
|
|
-occAnalCo !env (AppCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2
|
2481
|
|
-occAnalCo env (CoVarCo cv) = mkOneIdOcc env cv NotInteresting 0
|
2482
|
|
-occAnalCo _ (HoleCo hole) = pprPanic "occAnalCo:HoleCo" (ppr hole)
|
2483
|
|
-occAnalCo env (SymCo co) = occAnalCo env co
|
2484
|
|
-occAnalCo env (TransCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2
|
2485
|
|
-occAnalCo env (AxiomCo _ cos) = occAnalCos env cos
|
2486
|
|
-occAnalCo env (SelCo _ co) = occAnalCo env co
|
2487
|
|
-occAnalCo env (LRCo _ co) = occAnalCo env co
|
2488
|
|
-occAnalCo env (InstCo co arg) = occAnalCo env co `andUDs` occAnalCo env arg
|
2489
|
|
-occAnalCo env (KindCo co) = occAnalCo env co
|
2490
|
|
-occAnalCo env (SubCo co) = occAnalCo env co
|
2491
|
|
-occAnalCo env (TyConAppCo _ _ cos) = occAnalCos env cos
|
2492
|
|
-occAnalCo !env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })
|
2493
|
|
- = occAnalCo env cw `andUDs` occAnalCo env c1 `andUDs` occAnalCo env c2
|
2494
|
|
-occAnalCo env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos })
|
2495
|
|
- = occAnalTy env t1 `andUDs` occAnalTy env t2 `andUDs` occAnalCos env cos
|
2496
|
|
-occAnalCo env (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co })
|
2497
|
|
- = occAnalCo env kind_co `andUDs` delBndrsFromUDs [tv] (occAnalCo env co)
|
2498
|
|
-
|
2499
|
2503
|
occAnal :: OccEnv
|
2500
|
2504
|
-> CoreExpr
|
2501
|
2505
|
-> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids
|
... |
... |
@@ -2510,8 +2514,8 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], []) |
2510
|
2514
|
-- rules in them, so the *specialised* versions looked as if they
|
2511
|
2515
|
-- weren't used at all.
|
2512
|
2516
|
|
2513
|
|
-occAnal env (Type ty) = WUD (occAnalTy env ty) (Type ty)
|
2514
|
|
-occAnal env (Coercion co) = WUD (occAnalCo env co) (Coercion co)
|
|
2517
|
+occAnal _env (Type ty) = WUD (mkTyCoUDs (occAnalTy ty)) (Type ty)
|
|
2518
|
+occAnal _env (Coercion co) = WUD (mkTyCoUDs (occAnalCo co)) (Coercion co)
|
2515
|
2519
|
|
2516
|
2520
|
{- Note [Gather occurrences of coercion variables]
|
2517
|
2521
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
... |
... |
@@ -2589,10 +2593,10 @@ occAnal env (Tick tickish body) |
2589
|
2593
|
|
2590
|
2594
|
occAnal env (Cast expr co)
|
2591
|
2595
|
= let (WUD expr_uds expr') = occAnal env expr
|
2592
|
|
- co_uds = occAnalCo env co
|
|
2596
|
+ co_uds = occAnalCo co
|
2593
|
2597
|
-- co_uds: see Note [Gather occurrences of coercion variables]
|
2594
|
|
- uds = markAllNonTail (expr_uds `andUDs` co_uds)
|
2595
|
|
- -- co_uds': calls inside expr aren't tail calls any more
|
|
2598
|
+ uds = markAllNonTail (expr_uds `addTyCoOccs` co_uds)
|
|
2599
|
+ -- markAllNonTail: calls inside expr aren't tail calls any more
|
2596
|
2600
|
in WUD uds (Cast expr' co)
|
2597
|
2601
|
|
2598
|
2602
|
occAnal env app@(App _ _)
|
... |
... |
@@ -2614,7 +2618,9 @@ occAnal env (Case scrut bndr ty alts) |
2614
|
2618
|
tagged_bndr = tagLamBinder alts_usage bndr
|
2615
|
2619
|
in WUD alts_usage (tagged_bndr, alts')
|
2616
|
2620
|
|
2617
|
|
- total_usage = markAllNonTail scrut_usage `andUDs` alts_usage
|
|
2621
|
+ total_usage = markAllNonTail scrut_usage
|
|
2622
|
+ `andUDs` alts_usage
|
|
2623
|
+ `addTyCoOccs` occAnalTy ty
|
2618
|
2624
|
-- Alts can have tail calls, but the scrutinee can't
|
2619
|
2625
|
|
2620
|
2626
|
in WUD total_usage (Case scrut' tagged_bndr ty alts')
|
... |
... |
@@ -2719,7 +2725,7 @@ occAnalApp !env (Var fun, args, ticks) |
2719
|
2725
|
occAnalApp env (Var fun_id, args, ticks)
|
2720
|
2726
|
= WUD all_uds (mkTicks ticks app')
|
2721
|
2727
|
where
|
2722
|
|
- -- Lots of banged bindings: this is a very heavily bit of code,
|
|
2728
|
+ -- Lots of banged bindings: this is a very heavily used bit of code,
|
2723
|
2729
|
-- so it pays not to make lots of thunks here, all of which
|
2724
|
2730
|
-- will ultimately be forced.
|
2725
|
2731
|
!(fun', fun_id') = lookupBndrSwap env fun_id
|
... |
... |
@@ -3136,24 +3142,23 @@ addInScope :: OccEnv -> [Var] |
3136
|
3142
|
-- We do not assume that the bndrs are in scope order; in fact the
|
3137
|
3143
|
-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order
|
3138
|
3144
|
|
3139
|
|
--- Fast path when the is no environment-munging to do
|
3140
|
|
--- This is rather common: notably at top level, but nested too
|
3141
|
3145
|
addInScope env bndrs thing_inside
|
3142
|
3146
|
| null bndrs -- E.g. nullary constructors in a `case`
|
3143
|
3147
|
= thing_inside env
|
3144
|
3148
|
|
|
3149
|
+ -- Fast path when the is no environment-munging to do
|
|
3150
|
+ -- This is rather common: notably at top level, but nested too
|
3145
|
3151
|
| isEmptyVarEnv (occ_bs_env env)
|
3146
|
3152
|
, isEmptyVarEnv (occ_join_points env)
|
3147
|
3153
|
, WUD uds res <- thing_inside env
|
3148
|
3154
|
= WUD (delBndrsFromUDs bndrs uds) res
|
3149
|
3155
|
|
3150
|
|
-addInScope env bndrs thing_inside
|
|
3156
|
+ -- Normal path
|
|
3157
|
+ | let !(env', bad_joins) = preprocess_env env bndr_set
|
|
3158
|
+ !(WUD uds res) = thing_inside env'
|
|
3159
|
+ uds' = postprocess_uds bndrs bad_joins uds
|
|
3160
|
+ bndr_set = mkVarSet bndrs
|
3151
|
3161
|
= WUD uds' res
|
3152
|
|
- where
|
3153
|
|
- bndr_set = mkVarSet bndrs
|
3154
|
|
- !(env', bad_joins) = preprocess_env env bndr_set
|
3155
|
|
- !(WUD uds res) = thing_inside env'
|
3156
|
|
- uds' = postprocess_uds bndrs bad_joins uds
|
3157
|
3162
|
|
3158
|
3163
|
preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
|
3159
|
3164
|
preprocess_env env@(OccEnv { occ_join_points = join_points
|
... |
... |
@@ -3668,8 +3673,8 @@ For example, in (case x of A -> y; B -> y; C -> True), |
3668
|
3673
|
|
3669
|
3674
|
-}
|
3670
|
3675
|
|
3671
|
|
-type IdOccEnv = VarEnv LocalOcc -- A finite map from an expression's
|
3672
|
|
- -- free variables to their usage
|
|
3676
|
+type IdOccEnv = IdEnv LocalOcc -- A finite map from an expression's
|
|
3677
|
+ -- free variables to their usage
|
3673
|
3678
|
|
3674
|
3679
|
data LocalOcc -- See Note [LocalOcc]
|
3675
|
3680
|
= OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences
|
... |
... |
@@ -3690,9 +3695,7 @@ localTailCallInfo (ManyOccL tci) = tci |
3690
|
3695
|
|
3691
|
3696
|
-- For TyVars and CoVars we gather only whether it occurs once or
|
3692
|
3697
|
-- many times; we aren't interested in case-branches or tail-calls
|
3693
|
|
-data TyCoOccEnv = VarEnv TyCoOcc
|
3694
|
|
-
|
3695
|
|
-data TyCoOcc = OneOccTyCo | ManyOccTyCo
|
|
3698
|
+type TyCoOccEnv = TyCoVarEnv TyCoOccInfo
|
3696
|
3699
|
|
3697
|
3700
|
type ZappedSet = IdOccEnv
|
3698
|
3701
|
type ZappedTyCoSet = TyCoOccEnv
|
... |
... |
@@ -3704,24 +3707,19 @@ data UsageDetails |
3704
|
3707
|
, ud_z_many :: !ZappedSet -- apply 'markMany' to these
|
3705
|
3708
|
, ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these
|
3706
|
3709
|
, ud_z_tail :: !ZappedSet -- zap tail-call info for these
|
|
3710
|
+
|
3707
|
3711
|
, ud_tyco_env :: !TyCoOccEnv
|
3708
|
|
- , ud_z_tyzo :: !ZappedTyCoSet
|
|
3712
|
+ , ud_z_tyco :: !ZappedTyCoSet -- These ones occur many times
|
3709
|
3713
|
}
|
3710
|
3714
|
-- INVARIANT: `ud_z_many`, `ud_z_in_lam` and `ud_z_tail`
|
3711
|
|
-o -- are all subsets of ud_id_env
|
3712
|
|
- -- `ud_z_tyco` is a subset of ud_tycon_env
|
|
3715
|
+ -- are all subsets of ud_id_env
|
|
3716
|
+ -- `ud_z_tyco` is a subset of ud_tyco_env
|
3713
|
3717
|
|
3714
|
3718
|
instance Outputable UsageDetails where
|
3715
|
|
- ppr ud@(UD { ud_id_env = env, ud_tyco_env = tyco_env })
|
3716
|
|
- = text "UD" <+> (braces $ fsep $ punctuate comma $
|
3717
|
|
- [ ppr uq <+> text ":->" <+> ppr (lookupOccByUnique ud uq)
|
3718
|
|
- | uq <- nonDetStrictFoldVarEnv_Directly do_one [] id_env ]
|
3719
|
|
- ++
|
3720
|
|
- [ ppr uq <+> text ":->" <+> ppr (lookupTyCoOccByUnique ud uq)
|
3721
|
|
- | uq <- nonDetStrictFoldVarEnv_Directly do_one [] tyco_env ])
|
3722
|
|
- where
|
3723
|
|
- do_one :: Unique -> a -> [Unique] -> [Unique]
|
3724
|
|
- do_one uniq _ uniqs = uniq : uniqs
|
|
3719
|
+ ppr (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
|
|
3720
|
+ = text "UD" <+> (braces $ vcat
|
|
3721
|
+ [ text "ud_id_env =" <+> ppr id_env
|
|
3722
|
+ , text "ud_tyco_env =" <+> ppr tyco_env ])
|
3725
|
3723
|
|
3726
|
3724
|
---------------------
|
3727
|
3725
|
-- | TailUsageDetails captures the result of applying 'occAnalLamTail'
|
... |
... |
@@ -3743,18 +3741,13 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a |
3743
|
3741
|
-------------------
|
3744
|
3742
|
-- UsageDetails API
|
3745
|
3743
|
|
3746
|
|
-andUDs, orUDs
|
3747
|
|
- :: UsageDetails -> UsageDetails -> UsageDetails
|
|
3744
|
+plusTyCoOccEnv :: TyCoOccEnv -> TyCoOccEnv -> TyCoOccEnv
|
|
3745
|
+plusTyCoOccEnv env1 env2 = plusVarEnv_C plusTyCoOccInfo env1 env2
|
|
3746
|
+
|
|
3747
|
+andUDs, orUDs :: UsageDetails -> UsageDetails -> UsageDetails
|
3748
|
3748
|
andUDs = combineUsageDetailsWith andLocalOcc
|
3749
|
3749
|
orUDs = combineUsageDetailsWith orLocalOcc
|
3750
|
3750
|
|
3751
|
|
-mkOneTyVarOcc :: OccEnv -> TyVar -> UsageDetails
|
3752
|
|
-mkOneTyVarOcc !_env tv
|
3753
|
|
- = mkSimpleDetails (unitVarEnv tv occ)
|
3754
|
|
- where
|
3755
|
|
- occ = OneOccL { lo_n_br = 1, lo_int_cxt = NotInteresting
|
3756
|
|
- , lo_tail = NoTailCallInfo }
|
3757
|
|
-
|
3758
|
3751
|
mkOneIdOcc :: OccEnv -> Var -> InterestingCxt -> JoinArity -> UsageDetails
|
3759
|
3752
|
mkOneIdOcc !env id int_cxt arity
|
3760
|
3753
|
| assert (not (isTyVar id)) $
|
... |
... |
@@ -3765,10 +3758,10 @@ mkOneIdOcc !env id int_cxt arity |
3765
|
3758
|
= -- See Note [Occurrence analysis for join points]
|
3766
|
3759
|
assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $
|
3767
|
3760
|
-- We only put non-empty join-points into occ_join_points
|
3768
|
|
- mkSimpleDetails (extendVarEnv join_uds id occ)
|
|
3761
|
+ mkIdUDs (extendVarEnv join_uds id occ)
|
3769
|
3762
|
|
3770
|
3763
|
| otherwise
|
3771
|
|
- = mkSimpleDetails (unitVarEnv id occ)
|
|
3764
|
+ = mkIdUDs (unitVarEnv id occ)
|
3772
|
3765
|
|
3773
|
3766
|
where
|
3774
|
3767
|
occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt
|
... |
... |
@@ -3786,11 +3779,15 @@ add_many_occ v env = extendVarEnv env v (ManyOccL NoTailCallInfo) |
3786
|
3779
|
addManyOccs :: UsageDetails -> VarSet -> UsageDetails
|
3787
|
3780
|
addManyOccs uds var_set
|
3788
|
3781
|
| isEmptyVarSet var_set = uds
|
3789
|
|
- | otherwise = uds { ud_env = add_to (ud_env uds) }
|
|
3782
|
+ | otherwise = uds { ud_id_env = add_to (ud_id_env uds) }
|
3790
|
3783
|
where
|
3791
|
3784
|
add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set
|
3792
|
3785
|
-- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes
|
3793
|
3786
|
|
|
3787
|
+addTyCoOccs :: UsageDetails -> TyCoOccEnv -> UsageDetails
|
|
3788
|
+addTyCoOccs uds@(UD { ud_tyco_env = env}) extras
|
|
3789
|
+ = uds { ud_tyco_env = env `plusTyCoOccEnv` extras }
|
|
3790
|
+
|
3794
|
3791
|
addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
|
3795
|
3792
|
-- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var]
|
3796
|
3793
|
-- Add any TyCoVars free in the type of a lambda-binder
|
... |
... |
@@ -3801,39 +3798,52 @@ addLamTyCoVarOccs uds bndrs |
3801
|
3798
|
add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr)
|
3802
|
3799
|
|
3803
|
3800
|
emptyDetails :: UsageDetails
|
3804
|
|
-emptyDetails = mkSimpleDetails emptyVarEnv
|
|
3801
|
+emptyDetails = UD { ud_id_env = emptyVarEnv
|
|
3802
|
+ , ud_z_many = emptyVarEnv
|
|
3803
|
+ , ud_z_in_lam = emptyVarEnv
|
|
3804
|
+ , ud_z_tail = emptyVarEnv
|
|
3805
|
+ , ud_tyco_env = emptyVarEnv
|
|
3806
|
+ , ud_z_tyco = emptyVarEnv }
|
3805
|
3807
|
|
3806
|
3808
|
isEmptyDetails :: UsageDetails -> Bool
|
3807
|
|
-isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env
|
|
3809
|
+isEmptyDetails (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
|
|
3810
|
+ = isEmptyVarEnv id_env && isEmptyVarEnv tyco_env
|
|
3811
|
+
|
|
3812
|
+mkIdUDs :: IdOccEnv -> UsageDetails
|
|
3813
|
+mkIdUDs env = emptyDetails { ud_id_env = env }
|
3808
|
3814
|
|
3809
|
|
-mkSimpleDetails :: IdOccEnv -> UsageDetails
|
3810
|
|
-mkSimpleDetails env = UD { ud_env = env
|
3811
|
|
- , ud_z_many = emptyVarEnv
|
3812
|
|
- , ud_z_in_lam = emptyVarEnv
|
3813
|
|
- , ud_z_tail = emptyVarEnv }
|
|
3815
|
+mkTyCoUDs :: TyCoOccEnv -> UsageDetails
|
|
3816
|
+mkTyCoUDs env = emptyDetails { ud_tyco_env = env }
|
3814
|
3817
|
|
3815
|
3818
|
modifyUDEnv :: (IdOccEnv -> IdOccEnv) -> UsageDetails -> UsageDetails
|
3816
|
|
-modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }
|
|
3819
|
+modifyUDEnv f uds@(UD { ud_id_env = env }) = uds { ud_id_env = f env }
|
3817
|
3820
|
|
3818
|
3821
|
delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails
|
3819
|
3822
|
-- Delete these binders from the UsageDetails
|
3820
|
|
--- But /add/ the free vars of the types
|
3821
|
|
-delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many
|
3822
|
|
- , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail })
|
3823
|
|
- = UD { ud_env = env `delVarEnvList` bndrs
|
|
3823
|
+-- But /add/ the free vars of the types. That may seem odd, but this is
|
|
3824
|
+-- a very convenient place to do it!
|
|
3825
|
+delBndrsFromUDs bndrs (UD { ud_id_env = env, ud_z_many = z_many
|
|
3826
|
+ , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail
|
|
3827
|
+ , ud_tyco_env = tyco_env, ud_z_tyco = z_tyco })
|
|
3828
|
+ = UD { ud_id_env = env `delVarEnvList` bndrs
|
3824
|
3829
|
, ud_z_many = z_many `delVarEnvList` bndrs
|
3825
|
3830
|
, ud_z_in_lam = z_in_lam `delVarEnvList` bndrs
|
3826
|
|
- , ud_z_tail = z_tail `delVarEnvList` bndrs }
|
|
3831
|
+ , ud_z_tail = z_tail `delVarEnvList` bndrs
|
|
3832
|
+ , ud_tyco_env = adjust bndrs tyco_env
|
|
3833
|
+ , ud_z_tyco = z_tyco `delVarEnvList` bndrs
|
|
3834
|
+ }
|
3827
|
3835
|
where
|
3828
|
|
- ty_fvs [] = emptyVarSet
|
3829
|
|
- ty_fvs (b:bs) = tyCoVarsOfType b `unionVarSet`
|
3830
|
|
- (ty_fvs bs `delVarSet` b)
|
|
3836
|
+ adjust :: [Var] -> TyCoOccEnv -> TyCoOccEnv
|
|
3837
|
+ -- Delete binders, but add the free vars of their types
|
|
3838
|
+ adjust [] env = env
|
|
3839
|
+ adjust (b:bs) env = occAnalTy (varType b) `plusTyCoOccEnv`
|
|
3840
|
+ (adjust bs env `delVarEnv` b)
|
3831
|
3841
|
|
3832
|
3842
|
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
|
3833
|
3843
|
:: UsageDetails -> UsageDetails
|
3834
|
|
-markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env }
|
3835
|
|
-markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }
|
3836
|
|
-markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env }
|
|
3844
|
+markAllMany ud@(UD { ud_id_env = env }) = ud { ud_z_many = env }
|
|
3845
|
+markAllInsideLam ud@(UD { ud_id_env = env }) = ud { ud_z_in_lam = env }
|
|
3846
|
+markAllNonTail ud@(UD { ud_id_env = env }) = ud { ud_z_tail = env }
|
3837
|
3847
|
markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
|
3838
|
3848
|
|
3839
|
3849
|
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
|
... |
... |
@@ -3846,7 +3856,7 @@ markAllNonTailIf False ud = ud |
3846
|
3856
|
|
3847
|
3857
|
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
|
3848
|
3858
|
lookupTailCallInfo uds id
|
3849
|
|
- | UD { ud_z_tail = z_tail, ud_env = env } <- uds
|
|
3859
|
+ | UD { ud_z_tail = z_tail, ud_id_env = env } <- uds
|
3850
|
3860
|
, not (id `elemVarEnv` z_tail)
|
3851
|
3861
|
, Just occ <- lookupVarEnv env id
|
3852
|
3862
|
= localTailCallInfo occ
|
... |
... |
@@ -3855,9 +3865,10 @@ lookupTailCallInfo uds id |
3855
|
3865
|
|
3856
|
3866
|
udFreeVars :: VarSet -> UsageDetails -> VarSet
|
3857
|
3867
|
-- Find the subset of bndrs that are mentioned in uds
|
3858
|
|
-udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env
|
|
3868
|
+udFreeVars bndrs (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
|
|
3869
|
+ = restrictFreeVars bndrs id_env `unionVarSet` restrictFreeVars bndrs tyco_env
|
3859
|
3870
|
|
3860
|
|
-restrictFreeVars :: VarSet -> IdOccEnv -> VarSet
|
|
3871
|
+restrictFreeVars :: VarSet -> VarEnv a -> VarSet
|
3861
|
3872
|
restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
|
3862
|
3873
|
|
3863
|
3874
|
-------------------
|
... |
... |
@@ -3867,15 +3878,19 @@ combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) |
3867
|
3878
|
-> UsageDetails -> UsageDetails -> UsageDetails
|
3868
|
3879
|
{-# INLINE combineUsageDetailsWith #-}
|
3869
|
3880
|
combineUsageDetailsWith plus_occ_info
|
3870
|
|
- uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })
|
3871
|
|
- uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })
|
3872
|
|
- | isEmptyVarEnv env1 = uds2
|
3873
|
|
- | isEmptyVarEnv env2 = uds1
|
|
3881
|
+ uds1@(UD { ud_id_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1
|
|
3882
|
+ , ud_tyco_env = tyco_env1, ud_z_tyco = z_tyco1 })
|
|
3883
|
+ uds2@(UD { ud_id_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2
|
|
3884
|
+ , ud_tyco_env = tyco_env2, ud_z_tyco = z_tyco2 })
|
|
3885
|
+ | isEmptyDetails uds1 = uds2
|
|
3886
|
+ | isEmptyDetails uds2 = uds1
|
3874
|
3887
|
| otherwise
|
3875
|
|
- = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2
|
3876
|
|
- , ud_z_many = plusVarEnv z_many1 z_many2
|
3877
|
|
- , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2
|
3878
|
|
- , ud_z_tail = plusVarEnv z_tail1 z_tail2 }
|
|
3888
|
+ = UD { ud_id_env = plusVarEnv_C plus_occ_info env1 env2
|
|
3889
|
+ , ud_z_many = plusVarEnv z_many1 z_many2
|
|
3890
|
+ , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2
|
|
3891
|
+ , ud_z_tail = plusVarEnv z_tail1 z_tail2
|
|
3892
|
+ , ud_tyco_env = plusTyCoOccEnv tyco_env1 tyco_env2
|
|
3893
|
+ , ud_z_tyco = plusVarEnv z_tyco1 z_tyco2 }
|
3879
|
3894
|
|
3880
|
3895
|
lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
|
3881
|
3896
|
-- Don't use locally-generated occ_info for exported (visible-elsewhere)
|
... |
... |
@@ -3884,21 +3899,24 @@ lookupLetOccInfo :: UsageDetails -> Id -> OccInfo |
3884
|
3899
|
-- we are about to re-generate it and it shouldn't be "sticky"
|
3885
|
3900
|
lookupLetOccInfo ud id
|
3886
|
3901
|
| isExportedId id = noOccInfo
|
3887
|
|
- | otherwise = lookupOccByUnique ud (idUnique id)
|
|
3902
|
+ | otherwise = lookupIdOccByUnique ud (idUnique id)
|
|
3903
|
+
|
|
3904
|
+lookupIdOccInfo :: UsageDetails -> Id -> OccInfo
|
|
3905
|
+lookupIdOccInfo ud id = lookupIdOccByUnique ud (idUnique id)
|
3888
|
3906
|
|
3889
|
|
-lookupOccInfo :: UsageDetails -> Id -> OccInfo
|
3890
|
|
-lookupOccInfo ud id = lookupOccByUnique ud (idUnique id)
|
|
3907
|
+lookupTyCoOcc :: UsageDetails -> TyCoVar -> TyCoOccInfo
|
|
3908
|
+lookupTyCoOcc uds tcv = lookupTyCoOccByUnique uds (varUnique tcv)
|
3891
|
3909
|
|
3892
|
|
-lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOcc
|
3893
|
|
-lookupTyCoByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq
|
|
3910
|
+lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOccInfo
|
|
3911
|
+lookupTyCoOccByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq
|
3894
|
3912
|
= case lookupVarEnv_Directly env uniq of
|
3895
|
|
- Nothing -> Nothing
|
3896
|
|
- Just ManyOccTyCo -> Just ManyOccTyCo
|
3897
|
|
- Just OneOccTyCo | uniq `elemVarEnvByKey` z_tyco = Just ManyOccTyCo
|
3898
|
|
- | otherwise = Just OneOccTyCo
|
|
3913
|
+ Nothing -> TyCoDead
|
|
3914
|
+ Just TyCoOne | uniq `elemVarEnvByKey` z_tyco -> TyCoMany
|
|
3915
|
+ | otherwise -> TyCoOne
|
|
3916
|
+ Just occ -> occ
|
3899
|
3917
|
|
3900
|
|
-lookupOccByUnique :: UsageDetails -> Unique -> OccInfo
|
3901
|
|
-lookupOccByUnique (UD { ud_env = env
|
|
3918
|
+lookupIdOccByUnique :: UsageDetails -> Unique -> OccInfo
|
|
3919
|
+lookupIdOccByUnique (UD { ud_id_env = env
|
3902
|
3920
|
, ud_z_many = z_many
|
3903
|
3921
|
, ud_z_in_lam = z_in_lam
|
3904
|
3922
|
, ud_z_tail = z_tail })
|
... |
... |
@@ -3925,6 +3943,12 @@ lookupOccByUnique (UD { ud_env = env |
3925
|
3943
|
| otherwise = ti
|
3926
|
3944
|
|
3927
|
3945
|
|
|
3946
|
+tyCoOccToIdOcc :: TyCoOccInfo -> OccInfo
|
|
3947
|
+-- Used for CoVars
|
|
3948
|
+tyCoOccToIdOcc TyCoDead = IAmDead
|
|
3949
|
+tyCoOccToIdOcc TyCoOne = OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1
|
|
3950
|
+ , occ_int_cxt = NotInteresting, occ_tail = NoTailCallInfo }
|
|
3951
|
+tyCoOccToIdOcc TyCoMany = noOccInfo
|
3928
|
3952
|
|
3929
|
3953
|
-------------------
|
3930
|
3954
|
-- See Note [Adjusting right-hand sides]
|
... |
... |
@@ -3958,34 +3982,42 @@ adjustTailArity mb_rhs_ja (TUD ja usage) |
3958
|
3982
|
type IdWithOccInfo = Id
|
3959
|
3983
|
|
3960
|
3984
|
tagLamBinders :: UsageDetails -- Of scope
|
3961
|
|
- -> [Id] -- Binders
|
|
3985
|
+ -> [CoreBndr] -- Binders
|
3962
|
3986
|
-> [IdWithOccInfo] -- Tagged binders
|
3963
|
3987
|
tagLamBinders usage binders
|
3964
|
3988
|
= map (tagLamBinder usage) binders
|
3965
|
3989
|
|
3966
|
3990
|
tagLamBinder :: UsageDetails -- Of scope
|
3967
|
|
- -> Id -- Binder
|
|
3991
|
+ -> CoreBndr -- Binder
|
3968
|
3992
|
-> IdWithOccInfo -- Tagged binders
|
3969
|
3993
|
-- Used for lambda and case binders
|
3970
|
|
--- No-op on TyVars
|
|
3994
|
+-- No-op on TyVars; we could tag them but not much point
|
3971
|
3995
|
-- A lambda binder never has an unfolding, so no need to look for that
|
3972
|
3996
|
tagLamBinder usage bndr
|
3973
|
|
- = setBinderOcc (markNonTail occ) bndr
|
|
3997
|
+ | isTyCoVar bndr
|
|
3998
|
+ = bndr
|
|
3999
|
+ | otherwise
|
|
4000
|
+ = setIdBinderOcc (markNonTail occ) bndr
|
3974
|
4001
|
-- markNonTail: don't try to make an argument into a join point
|
3975
|
4002
|
where
|
3976
|
|
- occ = lookupOccInfo usage bndr
|
|
4003
|
+ occ = lookupIdOccInfo usage bndr
|
|
4004
|
+
|
|
4005
|
+tagTyCoBinder :: TyCoOccInfo -> TyCoVar -> TyCoVar
|
|
4006
|
+tagTyCoBinder occ bndr
|
|
4007
|
+ | isId bndr = setIdOccInfo bndr (tyCoOccToIdOcc occ)
|
|
4008
|
+ | otherwise = setTyVarOccInfo bndr occ
|
3977
|
4009
|
|
3978
|
4010
|
tagNonRecBinder :: TopLevelFlag -- At top level?
|
3979
|
4011
|
-> OccInfo -- Of scope
|
3980
|
|
- -> CoreBndr -- Binder
|
|
4012
|
+ -> Id -- Binder
|
3981
|
4013
|
-> (IdWithOccInfo, JoinPointHood) -- Tagged binder
|
3982
|
4014
|
-- Precondition: OccInfo is not IAmDead
|
3983
|
4015
|
tagNonRecBinder lvl occ bndr
|
3984
|
4016
|
| okForJoinPoint lvl bndr tail_call_info
|
3985
|
4017
|
, AlwaysTailCalled ar <- tail_call_info
|
3986
|
|
- = (setBinderOcc occ bndr, JoinPoint ar)
|
|
4018
|
+ = (setIdBinderOcc occ bndr, JoinPoint ar)
|
3987
|
4019
|
| otherwise
|
3988
|
|
- = (setBinderOcc zapped_occ bndr, NotJoinPoint)
|
|
4020
|
+ = (setIdBinderOcc zapped_occ bndr, NotJoinPoint)
|
3989
|
4021
|
where
|
3990
|
4022
|
tail_call_info = tailCallInfo occ
|
3991
|
4023
|
zapped_occ = markNonTail occ
|
... |
... |
@@ -4035,18 +4067,17 @@ tagRecBinders lvl body_uds details_s |
4035
|
4067
|
adj_uds = foldr andUDs body_uds rhs_udss'
|
4036
|
4068
|
|
4037
|
4069
|
-- 4. Tag each binder with its adjusted details
|
4038
|
|
- bndrs' = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr
|
|
4070
|
+ bndrs' = [ setIdBinderOcc (lookupLetOccInfo adj_uds bndr) bndr
|
4039
|
4071
|
| bndr <- bndrs ]
|
4040
|
4072
|
|
4041
|
4073
|
in
|
4042
|
4074
|
WUD adj_uds bndrs'
|
4043
|
4075
|
|
4044
|
|
-setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
|
4045
|
|
-setBinderOcc occ_info bndr
|
4046
|
|
- | isTyVar bndr = if (occ_info == tyVarOccInfo bndr) then bndr
|
4047
|
|
- else setTyVarOccInfo bndr occ_info
|
4048
|
|
- | otherwise = if (occ_info == idOccInfo bndr) then bndr
|
4049
|
|
- else setIdOccInfo bndr occ_info
|
|
4076
|
+setIdBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
|
|
4077
|
+setIdBinderOcc occ_info bndr
|
|
4078
|
+ = assertPpr (isNonCoVarId bndr) (ppr bndr) $
|
|
4079
|
+ if (occ_info == idOccInfo bndr) then bndr
|
|
4080
|
+ else setIdOccInfo bndr occ_info
|
4050
|
4081
|
|
4051
|
4082
|
-- | Decide whether some bindings should be made into join points or not, based
|
4052
|
4083
|
-- on its occurrences. This is
|