| ... |
... |
@@ -1625,6 +1625,15 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1625
|
1625
|
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
|
|
1626
|
1626
|
-- See Note [Account for casts in binding]
|
|
1627
|
1627
|
|
|
|
1628
|
+ -- Copy InlinePragma information from the parent Id.
|
|
|
1629
|
+ -- So if f has INLINE[1] so does spec_fn
|
|
|
1630
|
+ spec_inl_prag
|
|
|
1631
|
+ | not is_local -- See Note [Specialising imported functions]
|
|
|
1632
|
+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
|
|
|
1633
|
+ = neverInlinePragma
|
|
|
1634
|
+ | otherwise
|
|
|
1635
|
+ = inl_prag
|
|
|
1636
|
+
|
|
1628
|
1637
|
not_in_scope :: InterestingVarFun
|
|
1629
|
1638
|
not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)
|
|
1630
|
1639
|
|
| ... |
... |
@@ -1654,9 +1663,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1654
|
1663
|
|
|
1655
|
1664
|
; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args)
|
|
1656
|
1665
|
<- specHeader subst' rhs_bndrs all_call_args
|
|
1657
|
|
- ; (rule_bndrs, rule_lhs_args, spec_bndrs, spec_args)
|
|
1658
|
|
- <- return ( poly_qvars ++ rule_bndrs, rule_lhs_args
|
|
1659
|
|
- , poly_qvars ++ spec_bndrs, spec_args )
|
|
|
1666
|
+ ; let all_rule_bndrs = poly_qvars ++ rule_bndrs
|
|
|
1667
|
+ env' = env { se_subst = subst'' }
|
|
1660
|
1668
|
|
|
1661
|
1669
|
{-
|
|
1662
|
1670
|
; pprTrace "spec_call" (vcat
|
| ... |
... |
@@ -1664,7 +1672,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1664
|
1672
|
, text "call info: " <+> ppr _ci
|
|
1665
|
1673
|
, text "poly_qvars: " <+> ppr poly_qvars
|
|
1666
|
1674
|
, text "useful: " <+> ppr useful
|
|
1667
|
|
- , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
|
1675
|
+ , text "all_rule_bndrs:" <+> ppr all_rule_bndrs
|
|
1668
|
1676
|
, text "rule_lhs_args:" <+> ppr rule_lhs_args
|
|
1669
|
1677
|
, text "spec_bndrs:" <+> ppr spec_bndrs
|
|
1670
|
1678
|
, text "dx_binds:" <+> ppr dx_binds
|
| ... |
... |
@@ -1674,41 +1682,47 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1674
|
1682
|
return ()
|
|
1675
|
1683
|
-}
|
|
1676
|
1684
|
|
|
1677
|
|
- ; let inner_rhs_bndrs = dropList all_call_args rhs_bndrs
|
|
1678
|
|
- env' = env { se_subst = subst'' }
|
|
1679
|
|
- (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs
|
|
1680
|
|
-
|
|
1681
|
|
- all_rules = rules_acc ++ existing_rules
|
|
|
1685
|
+ -- Check for (a) usefulness and (b) not already covered
|
|
|
1686
|
+ -- See (SC1) in Note [Specialisations already covered]
|
|
|
1687
|
+ ; let all_rules = rules_acc ++ existing_rules
|
|
1682
|
1688
|
-- all_rules: we look both in the rules_acc (generated by this invocation
|
|
1683
|
1689
|
-- of specCalls), and in existing_rules (passed in to specCalls)
|
|
1684
|
1690
|
; if not useful -- No useful specialisation
|
|
1685
|
|
- || alreadyCovered env' rule_bndrs fn rule_lhs_args is_active all_rules
|
|
1686
|
|
- -- See (SC1) in Note [Specialisations already covered]
|
|
|
1691
|
+ || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules
|
|
1687
|
1692
|
then return spec_acc
|
|
1688
|
1693
|
else
|
|
1689
|
|
- do { -- Run the specialiser on the specialised RHS
|
|
1690
|
|
- (rhs_body', rhs_uds) <- specExpr env'' rhs_body
|
|
1691
|
|
-
|
|
1692
|
|
- -- Add the { d1' = dx1; d2' = dx2 } usage stuff
|
|
1693
|
|
- -- to the rhs_uds; see Note [Specialising Calls]
|
|
1694
|
|
- ; let all_spec_bndrs = spec_bndrs ++ inner_rhs_bndrs'
|
|
1695
|
|
- (spec_uds, dumped_dbs) = dumpUDs all_spec_bndrs (dx_binds `consDictBinds` rhs_uds)
|
|
1696
|
|
- spec_rhs = mkLams all_spec_bndrs $
|
|
1697
|
|
- wrapDictBindsE dumped_dbs rhs_body'
|
|
1698
|
|
- spec_fn_ty = exprType spec_rhs
|
|
|
1694
|
+
|
|
|
1695
|
+ -- Not useless, not already covered: make a specialised binding
|
|
|
1696
|
+ do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs
|
|
|
1697
|
+ (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs
|
|
|
1698
|
+
|
|
|
1699
|
+ -- Run the specialiser on the specialised RHS
|
|
|
1700
|
+ ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body
|
|
|
1701
|
+
|
|
|
1702
|
+ -- Make the RHS of the specialised function
|
|
|
1703
|
+ ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'
|
|
|
1704
|
+ (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds
|
|
|
1705
|
+ (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1)
|
|
|
1706
|
+ -- dx_binds comes from the arguments to the call, and so can mention
|
|
|
1707
|
+ -- poly_qvars but no other local binders
|
|
|
1708
|
+ spec_rhs = mkLams poly_qvars $
|
|
|
1709
|
+ wrapDictBindsE outer_dumped_dbs $
|
|
|
1710
|
+ mkLams spec_rhs_bndrs $
|
|
|
1711
|
+ wrapDictBindsE inner_dumped_dbs rhs_body'
|
|
|
1712
|
+ rule_rhs_args = poly_qvars ++ spec_bndrs
|
|
1699
|
1713
|
|
|
1700
|
1714
|
-- Maybe add a void arg to the specialised function,
|
|
1701
|
1715
|
-- to avoid unlifted bindings
|
|
1702
|
1716
|
-- See Note [Specialisations Must Be Lifted]
|
|
1703
|
1717
|
-- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg
|
|
|
1718
|
+
|
|
|
1719
|
+ spec_fn_ty = exprType spec_rhs
|
|
1704
|
1720
|
add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn)
|
|
1705
|
|
- (spec_bndrs1, spec_rhs1, spec_fn_ty1)
|
|
1706
|
|
- | add_void_arg = ( voidPrimId : spec_bndrs
|
|
|
1721
|
+ (rule_rhs_args1, spec_rhs1, spec_fn_ty1)
|
|
|
1722
|
+ | add_void_arg = ( voidPrimId : rule_rhs_args
|
|
1707
|
1723
|
, Lam voidArgId spec_rhs
|
|
1708
|
|
- , mkVisFunTyMany unboxedUnitTy spec_fn_ty)
|
|
1709
|
|
- | otherwise = (spec_bndrs, spec_rhs, spec_fn_ty)
|
|
1710
|
|
-
|
|
1711
|
|
- join_arity_decr = length rule_lhs_args - length spec_bndrs1
|
|
|
1724
|
+ , mkVisFunTyMany unboxedUnitTy spec_fn_ty )
|
|
|
1725
|
+ | otherwise = (rule_rhs_args, spec_rhs, spec_fn_ty)
|
|
1712
|
1726
|
|
|
1713
|
1727
|
--------------------------------------
|
|
1714
|
1728
|
-- Add a suitable unfolding; see Note [Inline specialisations]
|
| ... |
... |
@@ -1716,22 +1730,14 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1716
|
1730
|
-- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
|
|
1717
|
1731
|
simpl_opts = initSimpleOpts dflags
|
|
1718
|
1732
|
wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
|
|
1719
|
|
- spec_unf = specUnfolding simpl_opts spec_bndrs1 wrap_unf_body
|
|
|
1733
|
+ spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body
|
|
1720
|
1734
|
rule_lhs_args fn_unf
|
|
1721
|
1735
|
|
|
1722
|
1736
|
--------------------------------------
|
|
1723
|
1737
|
-- Adding arity information just propagates it a bit faster
|
|
1724
|
1738
|
-- See Note [Arity decrease] in GHC.Core.Opt.Simplify
|
|
1725
|
|
- -- Copy InlinePragma information from the parent Id.
|
|
1726
|
|
- -- So if f has INLINE[1] so does spec_fn
|
|
1727
|
|
- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs1
|
|
1728
|
|
-
|
|
1729
|
|
- spec_inl_prag
|
|
1730
|
|
- | not is_local -- See Note [Specialising imported functions]
|
|
1731
|
|
- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
|
|
1732
|
|
- = neverInlinePragma
|
|
1733
|
|
- | otherwise
|
|
1734
|
|
- = inl_prag
|
|
|
1739
|
+ join_arity_decr = length rule_lhs_args - length rule_rhs_args1
|
|
|
1740
|
+ arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args1
|
|
1735
|
1741
|
|
|
1736
|
1742
|
spec_fn_info
|
|
1737
|
1743
|
= vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)
|
| ... |
... |
@@ -1758,10 +1764,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1758
|
1764
|
text "SPEC"
|
|
1759
|
1765
|
|
|
1760
|
1766
|
spec_rule = mkSpecRule dflags this_mod True inl_act
|
|
1761
|
|
- herald fn rule_bndrs rule_lhs_args
|
|
1762
|
|
- (mkVarApps (Var spec_fn) spec_bndrs1)
|
|
1763
|
|
-
|
|
1764
|
|
- spec_f_w_arity = spec_fn
|
|
|
1767
|
+ herald fn all_rule_bndrs rule_lhs_args
|
|
|
1768
|
+ (mkVarApps (Var spec_fn) rule_rhs_args1)
|
|
1765
|
1769
|
|
|
1766
|
1770
|
_rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
|
|
1767
|
1771
|
, ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1
|
| ... |
... |
@@ -1772,9 +1776,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1772
|
1776
|
]
|
|
1773
|
1777
|
|
|
1774
|
1778
|
; -- pprTrace "spec_call: rule" _rule_trace_doc
|
|
1775
|
|
- return ( spec_rule : rules_acc
|
|
1776
|
|
- , (spec_f_w_arity, spec_rhs1) : pairs_acc
|
|
1777
|
|
- , spec_uds `thenUDs` uds_acc
|
|
|
1779
|
+ return ( spec_rule : rules_acc
|
|
|
1780
|
+ , (spec_fn, spec_rhs1) : pairs_acc
|
|
|
1781
|
+ , rhs_uds2 `thenUDs` uds_acc
|
|
1778
|
1782
|
) } }
|
|
1779
|
1783
|
|
|
1780
|
1784
|
alreadyCovered :: SpecEnv
|
| ... |
... |
@@ -2550,7 +2554,8 @@ specHeader |
|
2550
|
2554
|
|
|
2551
|
2555
|
-- Specialised function helpers
|
|
2552
|
2556
|
-- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`
|
|
2553
|
|
- , [OutBndr] -- spec_bndrs: Binders for $sf. Subset of rule_bndrs.
|
|
|
2557
|
+ , [OutBndr] -- spec_bndrs: Binders for $sf, and args for the RHS
|
|
|
2558
|
+ -- of the RULE. Subset of rule_bndrs.
|
|
2554
|
2559
|
, [DictBind] -- dx_binds: Auxiliary dictionary bindings
|
|
2555
|
2560
|
, [OutExpr] -- spec_args: Specialised arguments for unfolding
|
|
2556
|
2561
|
-- Same length as "Args for LHS of rule"
|
| ... |
... |
@@ -2613,7 +2618,7 @@ specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) |
|
2613
|
2618
|
|
|
2614
|
2619
|
; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx }
|
|
2615
|
2620
|
; pure ( True, subst3 -- Ha! A useful specialisation!
|
|
2616
|
|
- , bndr' : rule_bs, Var bndr' : rule_es
|
|
|
2621
|
+ , bndr' : rule_bs, Var bndr' : rule_es
|
|
2617
|
2622
|
, spec_bs, dx', spec_dict : spec_args ) }
|
|
2618
|
2623
|
|
|
2619
|
2624
|
-- Finally, we don't want to specialise on this argument 'i':
|