| ... |
... |
@@ -1205,14 +1205,21 @@ specExpr env (Tick tickish body) |
|
1205
|
1205
|
---------------- Applications might generate a call instance --------------------
|
|
1206
|
1206
|
specExpr env expr@(App {})
|
|
1207
|
1207
|
= do { let (fun_in, args_in) = collectArgs expr
|
|
|
1208
|
+ ; (fun_out, uds_fun) <- specExpr env fun_in
|
|
1208
|
1209
|
; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in
|
|
1209
|
|
- ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args
|
|
1210
|
|
- -- Some dicts may have floated out of args_in;
|
|
1211
|
|
- -- they should be in scope for fireRewriteRules (#21689)
|
|
1212
|
|
- (fun_in', args_out') = fireRewriteRules env_args fun_in args_out
|
|
1213
|
|
- ; (fun_out', uds_fun) <- specExpr env fun_in'
|
|
|
1210
|
+ ; let uds_app = uds_fun `thenUDs` uds_args
|
|
|
1211
|
+ env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app
|
|
|
1212
|
+ -- zapSubst: we have now fully applied the substitution
|
|
|
1213
|
+ -- bringFloatedDictsIntoScope: some dicts may have floated out of
|
|
|
1214
|
+ -- args_in; they should be in scope for fireRewriteRules (#21689)
|
|
|
1215
|
+
|
|
|
1216
|
+ -- Try firing rewrite rules
|
|
|
1217
|
+ -- See Note [Fire rules in the specialiser]
|
|
|
1218
|
+ ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out
|
|
|
1219
|
+
|
|
|
1220
|
+ -- Make a call record, and return
|
|
1214
|
1221
|
; let uds_call = mkCallUDs env fun_out' args_out'
|
|
1215
|
|
- ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }
|
|
|
1222
|
+ ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) }
|
|
1216
|
1223
|
|
|
1217
|
1224
|
---------------- Lambda/case require dumping of usage details --------------------
|
|
1218
|
1225
|
specExpr env e@(Lam {})
|
| ... |
... |
@@ -1246,17 +1253,18 @@ specExpr env (Let bind body) |
|
1246
|
1253
|
-- See Note [Specialisation modulo dictionary selectors]
|
|
1247
|
1254
|
-- Note [ClassOp/DFun selection]
|
|
1248
|
1255
|
-- Note [Fire rules in the specialiser]
|
|
1249
|
|
-fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
|
|
|
1256
|
+fireRewriteRules :: SpecEnv -- Substitution is already zapped
|
|
|
1257
|
+ -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr])
|
|
1250
|
1258
|
fireRewriteRules env (Var f) args
|
|
1251
|
1259
|
| let rules = getRules (se_rules env) f
|
|
1252
|
1260
|
, Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules
|
|
1253
|
1261
|
, let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]
|
|
1254
|
|
- zapped_subst = Core.zapSubst (se_subst env)
|
|
1255
|
|
- expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr
|
|
|
1262
|
+ zapped_subst = se_subst env -- Just needed for the InScopeSet
|
|
|
1263
|
+ expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args)
|
|
1256
|
1264
|
-- simplOptExpr needed because lookupRule returns
|
|
1257
|
1265
|
-- (\x y. rhs) arg1 arg2
|
|
1258
|
1266
|
, (fun', args') <- collectArgs expr'
|
|
1259
|
|
- = fireRewriteRules env fun' (args'++rest_args)
|
|
|
1267
|
+ = fireRewriteRules env fun' args'
|
|
1260
|
1268
|
fireRewriteRules _ fun args = (fun, args)
|
|
1261
|
1269
|
|
|
1262
|
1270
|
--------------
|
| ... |
... |
@@ -1669,10 +1677,19 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1669
|
1677
|
; let all_rule_bndrs = poly_qvars ++ rule_bndrs
|
|
1670
|
1678
|
env' = env { se_subst = subst'' }
|
|
1671
|
1679
|
|
|
1672
|
|
-{-
|
|
1673
|
|
- ; pprTrace "spec_call" (vcat
|
|
|
1680
|
+ -- Check for (a) usefulness and (b) not already covered
|
|
|
1681
|
+ -- See (SC1) in Note [Specialisations already covered]
|
|
|
1682
|
+ ; let all_rules = rules_acc ++ existing_rules
|
|
|
1683
|
+ -- all_rules: we look both in the rules_acc (generated by this invocation
|
|
|
1684
|
+ -- of specCalls), and in existing_rules (passed in to specCalls)
|
|
|
1685
|
+ already_covered = alreadyCovered env' all_rule_bndrs fn
|
|
|
1686
|
+ rule_lhs_args is_active all_rules
|
|
|
1687
|
+
|
|
|
1688
|
+{- ; pprTrace "spec_call" (vcat
|
|
1674
|
1689
|
[ text "fun: " <+> ppr fn
|
|
1675
|
1690
|
, text "call info: " <+> ppr _ci
|
|
|
1691
|
+ , text "useful: " <+> ppr useful
|
|
|
1692
|
+ , text "already_covered:" <+> ppr already_covered
|
|
1676
|
1693
|
, text "poly_qvars: " <+> ppr poly_qvars
|
|
1677
|
1694
|
, text "useful: " <+> ppr useful
|
|
1678
|
1695
|
, text "all_rule_bndrs:" <+> ppr all_rule_bndrs
|
| ... |
... |
@@ -1681,17 +1698,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1681
|
1698
|
, text "dx_binds:" <+> ppr dx_binds
|
|
1682
|
1699
|
, text "spec_args: " <+> ppr spec_args
|
|
1683
|
1700
|
, text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
1684
|
|
- , text "rhs_body" <+> ppr rhs_body ]) $
|
|
|
1701
|
+ , text "rhs_body" <+> ppr rhs_body
|
|
|
1702
|
+ , text "subst''" <+> ppr subst'' ]) $
|
|
1685
|
1703
|
return ()
|
|
1686
|
1704
|
-}
|
|
1687
|
1705
|
|
|
1688
|
|
- -- Check for (a) usefulness and (b) not already covered
|
|
1689
|
|
- -- See (SC1) in Note [Specialisations already covered]
|
|
1690
|
|
- ; let all_rules = rules_acc ++ existing_rules
|
|
1691
|
|
- -- all_rules: we look both in the rules_acc (generated by this invocation
|
|
1692
|
|
- -- of specCalls), and in existing_rules (passed in to specCalls)
|
|
1693
|
|
- ; if not useful -- No useful specialisation
|
|
1694
|
|
- || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules
|
|
|
1706
|
+ ; if not useful -- No useful specialisation
|
|
|
1707
|
+ || already_covered -- Useful, but done already
|
|
1695
|
1708
|
then return spec_acc
|
|
1696
|
1709
|
else
|
|
1697
|
1710
|
|
| ... |
... |
@@ -1702,6 +1715,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1702
|
1715
|
-- Run the specialiser on the specialised RHS
|
|
1703
|
1716
|
; (rhs_body', rhs_uds) <- specExpr env'' rhs_body
|
|
1704
|
1717
|
|
|
|
1718
|
+{- ; pprTrace "spec_call2" (vcat
|
|
|
1719
|
+ [ text "fun:" <+> ppr fn
|
|
|
1720
|
+ , text "rhs_body':" <+> ppr rhs_body' ]) $
|
|
|
1721
|
+ return ()
|
|
|
1722
|
+-}
|
|
|
1723
|
+
|
|
1705
|
1724
|
-- Make the RHS of the specialised function
|
|
1706
|
1725
|
; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'
|
|
1707
|
1726
|
(rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds
|