... |
... |
@@ -1071,7 +1071,7 @@ dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm |
1071
|
1071
|
dsSpec_help :: Name -> Id -> CoreExpr -- Function to specialise
|
1072
|
1072
|
-> InlinePragma -> [Var] -> CoreExpr
|
1073
|
1073
|
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
|
1074
|
|
-dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call
|
|
1074
|
+dsSpec_help poly_nm poly_id poly_rhs inl orig_bndrs ds_call
|
1075
|
1075
|
= do {
|
1076
|
1076
|
-- Simplify the (desugared) call; see wrinkle (SP1)
|
1077
|
1077
|
-- in Note [Desugaring new-form SPECIALISE pragmas]
|
... |
... |
@@ -1079,21 +1079,20 @@ dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call |
1079
|
1079
|
; let simpl_opts = initSimpleOpts dflags
|
1080
|
1080
|
core_call = simpleOptExprNoInline simpl_opts ds_call
|
1081
|
1081
|
|
1082
|
|
- ; case prepareSpecLHS poly_id bndrs core_call of {
|
|
1082
|
+ ; case decomposeCall poly_id [] core_call of {
|
1083
|
1083
|
Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
|
1084
|
1084
|
; return Nothing } ;
|
1085
|
1085
|
|
1086
|
|
- Just (bndr_set, spec_const_binds, rule_lhs_args) ->
|
|
1086
|
+ Just (rev_binds, rule_lhs_args) ->
|
1087
|
1087
|
|
1088
|
|
- do { let const_bndrs = mkVarSet (bindersOfBinds spec_const_binds)
|
1089
|
|
- all_bndrs = bndr_set `unionVarSet` const_bndrs
|
1090
|
|
- -- all_bndrs: all binders in core_call that should be quantified
|
|
1088
|
+ do { let orig_bndr_set = mkVarSet orig_bndrs
|
|
1089
|
+ rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` orig_bndr_set)
|
|
1090
|
+ rule_lhs_args)
|
|
1091
|
+ spec_binds = grabSpecBinds orig_bndr_set (mkVarSet rule_bndrs) rev_binds
|
|
1092
|
+ spec_binds_bndr_set = mkVarSet (bindersOfBinds spec_binds)
|
|
1093
|
+ spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs
|
1091
|
1094
|
|
1092
|
|
- -- rule_bndrs; see (SP3) in Note [Desugaring new-form SPECIALISE pragmas]
|
1093
|
|
- rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` all_bndrs) rule_lhs_args)
|
1094
|
|
- spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
|
1095
|
|
-
|
1096
|
|
- mk_spec_body fn_body = mkLets spec_const_binds $
|
|
1095
|
+ mk_spec_body fn_body = mkLets spec_binds $
|
1097
|
1096
|
mkApps fn_body rule_lhs_args
|
1098
|
1097
|
-- ToDo: not mkCoreApps! That uses exprType on fun which
|
1099
|
1098
|
-- fails in specUnfolding, sigh
|
... |
... |
@@ -1117,11 +1116,64 @@ dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call |
1117
|
1116
|
rule_bndrs poly_id rule_lhs_args
|
1118
|
1117
|
spec_bndrs mk_spec_body inl } } }
|
1119
|
1118
|
|
1120
|
|
-prepareSpecLHS :: Id -> [EvVar] -> CoreExpr
|
1121
|
|
- -> Maybe (VarSet, [CoreBind], [CoreExpr])
|
1122
|
|
--- See Note [prepareSpecLHS]
|
1123
|
|
-prepareSpecLHS poly_id evs the_call
|
1124
|
|
- = go (mkVarSet evs) [] the_call
|
|
1119
|
+decomposeCall :: Id -> CoreExpr
|
|
1120
|
+ -> Maybe ( [CoreBind] -- Reversed bindings
|
|
1121
|
+ , [CoreExpr] ) -- Args of the call
|
|
1122
|
+decomposeCall poly_id binds
|
|
1123
|
+ = go [] binds
|
|
1124
|
+ where
|
|
1125
|
+ go acc (Let bind body)
|
|
1126
|
+ = go (bind:acc) body
|
|
1127
|
+ go add e
|
|
1128
|
+ | Just (Var fun, args) <- collectArgs e
|
|
1129
|
+ = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $
|
|
1130
|
+ Just (acc, args)
|
|
1131
|
+ | otherwise
|
|
1132
|
+ = Nothing
|
|
1133
|
+
|
|
1134
|
+
|
|
1135
|
+grabSpecBinds :: VarSet -> VarSet -> [CoreBind] -> [CoreBind]
|
|
1136
|
+grabSpecBinds orig_bndrs rule_bndrs rev_binds
|
|
1137
|
+ = rename_binds ++ spec_binds
|
|
1138
|
+ where
|
|
1139
|
+ (known_bndrs, rename_binds, other_binds)
|
|
1140
|
+ = get_renamings rule_bndrs ([],[]) rev_binds
|
|
1141
|
+ spec_binds = pick_spec_binds known_bndrs other_binds
|
|
1142
|
+
|
|
1143
|
+ ------------------------
|
|
1144
|
+ get_renamings :: VarSet -- Variables bound by a successful match on the call
|
|
1145
|
+ -> ([CoreBind],[CoreBind]) -- Accumulating parameter, in order
|
|
1146
|
+ -> [CoreBind] -- Reversed, innermost first
|
|
1147
|
+ -> ( VarSet
|
|
1148
|
+ , [CoreBind] -- Renamings, in order
|
|
1149
|
+ , [CoreBind]) -- Other bindings, in order
|
|
1150
|
+ get_renamings _ acc [] acc
|
|
1151
|
+
|
|
1152
|
+ get_renamings bndrs (rn_binds, other_binds) (bind : binds)
|
|
1153
|
+ | NonRec d r <- bind
|
|
1154
|
+ , d `elemVarSet` bndrs
|
|
1155
|
+ , Just (v, mco) <- getCastedVar r
|
|
1156
|
+ , let flipped_bind = NonRec v (mkCastMCo (Var d) (mkSymMCo mco))
|
|
1157
|
+ = get_renamings (bndrs `extendVarSet` v)
|
|
1158
|
+ (flipped_bind:rn_binds, other_binds)
|
|
1159
|
+ binds
|
|
1160
|
+ | otherwise
|
|
1161
|
+ = get_renamings bndrs (rn_binds, bind:other_binds) binds
|
|
1162
|
+
|
|
1163
|
+ ------------------------
|
|
1164
|
+ pick_spec_binds :: VarSet -> [CoreBind] -> [CoreBind]
|
|
1165
|
+ pick_spec_binds known_bndrs [] = []
|
|
1166
|
+ pick_spec_binds known_bndrs (bind:binds)
|
|
1167
|
+ | all keep_me (rhssOfBind bind)
|
|
1168
|
+ , let known_bndrs' = known_bndrs `extendVarSetList` bindersOfBind bind
|
|
1169
|
+ = bind : pick_spec_binds known_bndrs' binds
|
|
1170
|
+ | otherwise
|
|
1171
|
+ = pick_spec_binds known_bndrs binds
|
|
1172
|
+ where
|
|
1173
|
+ keep_me rhs = isEmptyVarSet (exprSomFreeVars bad_var rhs)
|
|
1174
|
+ bad_var v = v `elemVarSet` orig_bndrs && not (bndr `elemVarSet` known_bndrs)
|
|
1175
|
+
|
|
1176
|
+{-
|
1125
|
1177
|
where
|
1126
|
1178
|
go :: VarSet -- Quantified variables, or dependencies thereof
|
1127
|
1179
|
-> [CoreBind] -- Reversed list of constant evidence bindings
|
... |
... |
@@ -1133,7 +1185,7 @@ prepareSpecLHS poly_id evs the_call |
1133
|
1185
|
| not (all (isPredTy . varType) bndrs)
|
1134
|
1186
|
-- A normal 'let' is too complicated
|
1135
|
1187
|
-- But we definitely include quantified constraints
|
1136
|
|
- -- E.g. this is fine: let (d :: forall a. Eq a => Eq (f a) = d2
|
|
1188
|
+ -- E.g. this is fine: let (d :: forall a. Eq a => Eq (f a) = d2)
|
1137
|
1189
|
= Nothing
|
1138
|
1190
|
|
1139
|
1191
|
-- (a) (1) in Note [prepareSpecLHS]
|
... |
... |
@@ -1156,10 +1208,10 @@ prepareSpecLHS poly_id evs the_call |
1156
|
1208
|
= Nothing
|
1157
|
1209
|
|
1158
|
1210
|
transfer_to_spec_rhs qevs rhs
|
1159
|
|
- = isEmptyVarSet $ exprSomeFreeVars is_quant_id rhs
|
1160
|
1211
|
where
|
1161
|
1212
|
is_quant_id v = isId v && v `elemVarSet` qevs
|
1162
|
1213
|
-- See (a) (2) in Note [prepareSpecLHS]
|
|
1214
|
+-}
|
1163
|
1215
|
|
1164
|
1216
|
finishSpecPrag :: Name -> CoreExpr -- RHS to specialise
|
1165
|
1217
|
-> [Var] -> Id -> [CoreExpr] -- RULE LHS pattern
|