| ... |
... |
@@ -66,7 +66,6 @@ import GHC.Builtin.Names( runRWKey ) |
|
66
|
66
|
import GHC.Unit.Module( Module )
|
|
67
|
67
|
|
|
68
|
68
|
import Data.List (mapAccumL)
|
|
69
|
|
-import Data.List.NonEmpty (NonEmpty (..))
|
|
70
|
69
|
|
|
71
|
70
|
{-
|
|
72
|
71
|
************************************************************************
|
| ... |
... |
@@ -1040,10 +1039,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine |
|
1040
|
1039
|
| mb_join@(JoinPoint {}) <- idJoinPointHood bndr
|
|
1041
|
1040
|
= -- Analyse the RHS and /then/ the body
|
|
1042
|
1041
|
let -- Analyse the rhs first, generating rhs_uds
|
|
1043
|
|
- !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs
|
|
1044
|
|
- rhs_uds = foldl1' (combineJoinPointUDs env)
|
|
1045
|
|
- rhs_uds_s -- NB: combineJoinPointUDs. See (W4) of
|
|
1046
|
|
- -- Note [Occurrence analysis for join points]
|
|
|
1042
|
+ !(rhs_uds, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs
|
|
1047
|
1043
|
|
|
1048
|
1044
|
-- Now analyse the body, adding the join point
|
|
1049
|
1045
|
-- into the environment with addJoinPoint
|
| ... |
... |
@@ -1053,9 +1049,9 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine |
|
1053
|
1049
|
in
|
|
1054
|
1050
|
if isDeadOcc occ -- Drop dead code; see Note [Dead code]
|
|
1055
|
1051
|
then WUD body_uds body
|
|
1056
|
|
- else -- pprTrace "occAnal-nonrec" (vcat [ ppr bndr <+> ppr occ
|
|
1057
|
|
- -- , text "rhs_uds" <+> ppr rhs_uds
|
|
1058
|
|
- -- , text "body_uds" <+> ppr body_uds ]) $
|
|
|
1052
|
+ else pprTrace "occAnal-nonrec" (vcat [ ppr bndr <+> ppr occ
|
|
|
1053
|
+ , text "rhs_uds" <+> ppr rhs_uds
|
|
|
1054
|
+ , text "body_uds" <+> ppr body_uds ]) $
|
|
1059
|
1055
|
WUD (combineJoinPointUDs env rhs_uds body_uds) -- Note `orUDs`
|
|
1060
|
1056
|
(combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']
|
|
1061
|
1057
|
body)
|
| ... |
... |
@@ -1072,8 +1068,8 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine |
|
1072
|
1068
|
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
|
|
1073
|
1069
|
(tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
|
|
1074
|
1070
|
|
|
1075
|
|
- !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs
|
|
1076
|
|
- in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs`
|
|
|
1071
|
+ !(rhs_uds, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs
|
|
|
1072
|
+ in WUD (rhs_uds `andUDs` body_uds) -- Note `andUDs`
|
|
1077
|
1073
|
(combine [NonRec final_bndr rhs'] body)
|
|
1078
|
1074
|
|
|
1079
|
1075
|
-----------------
|
| ... |
... |
@@ -1088,15 +1084,21 @@ occAnalNonRecBody env bndr thing_inside |
|
1088
|
1084
|
|
|
1089
|
1085
|
-----------------
|
|
1090
|
1086
|
occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges
|
|
1091
|
|
- -> JoinPointHood -> Id -> CoreExpr
|
|
1092
|
|
- -> (NonEmpty UsageDetails, Id, CoreExpr)
|
|
|
1087
|
+ -> JoinPointHood -> Id -> CoreExpr
|
|
|
1088
|
+ -> (UsageDetails, Id, CoreExpr)
|
|
1093
|
1089
|
occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
|
|
1094
|
1090
|
| null rules, null imp_rule_infos
|
|
1095
|
1091
|
= -- Fast path for common case of no rules. This is only worth
|
|
1096
|
1092
|
-- 0.1% perf on average, but it's also only a line or two of code
|
|
1097
|
|
- ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs )
|
|
|
1093
|
+ ( adj_rhs_uds `orUDs` adj_unf_uds
|
|
|
1094
|
+ , final_bndr_no_rules, final_rhs )
|
|
|
1095
|
+
|
|
1098
|
1096
|
| otherwise
|
|
1099
|
|
- = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )
|
|
|
1097
|
+ = ( foldl' orUDs (adj_rhs_uds `orUDs` adj_unf_uds) adj_rule_uds
|
|
|
1098
|
+ , final_bndr_with_rules, final_rhs )
|
|
|
1099
|
+
|
|
|
1100
|
+ -- orUDs: Combine the RHS, (stable) unfolding, and RULES with orUDs
|
|
|
1101
|
+ -- See (W4) of Note [Occurrence analysis for join points]
|
|
1100
|
1102
|
where
|
|
1101
|
1103
|
--------- Right hand side ---------
|
|
1102
|
1104
|
-- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have
|