| ... |
... |
@@ -1728,6 +1728,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1728
|
1728
|
-- , text "rhs_bndrs" <+> ppr (sep (map (pprBndr LambdaBind) rhs_bndrs))
|
|
1729
|
1729
|
-- , text "rhs_body" <+> ppr rhs_body
|
|
1730
|
1730
|
-- , text "subst'" <+> ppr subst'
|
|
|
1731
|
+-- , text "subst_in_scope'" <+> ppr (substInScopeSet subst')
|
|
1731
|
1732
|
-- ]) $ return ()
|
|
1732
|
1733
|
|
|
1733
|
1734
|
|
| ... |
... |
@@ -1819,11 +1820,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1819
|
1820
|
, text "rule_act" <+> ppr rule_act
|
|
1820
|
1821
|
]
|
|
1821
|
1822
|
|
|
1822
|
|
--- ; pprTrace "spec_call: rule" (vcat [ -- text "poly_qvars" <+> ppr poly_qvars
|
|
1823
|
|
--- text "rule_bndrs" <+> ppr rule_bndrs
|
|
|
1823
|
+-- ; pprTrace "spec_call: rule" (vcat [ text "rule_bndrs" <+> ppr rule_bndrs
|
|
1824
|
1824
|
-- , text "rule_lhs_args" <+> ppr rule_lhs_args
|
|
1825
|
1825
|
-- , text "all_call_args" <+> ppr all_call_args
|
|
1826
|
1826
|
-- , ppr spec_rule ]) $
|
|
|
1827
|
+-- return ()
|
|
|
1828
|
+
|
|
1827
|
1829
|
; return ( spec_rule : rules_acc
|
|
1828
|
1830
|
, (spec_fn, spec_rhs1) : pairs_acc
|
|
1829
|
1831
|
, rhs_uds2 `thenUDs` uds_acc
|
| ... |
... |
@@ -2703,6 +2705,11 @@ specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) |
|
2703
|
2705
|
; (_, subst4, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst3 bndrs args
|
|
2704
|
2706
|
|
|
2705
|
2707
|
; let dx' = tv_binds `appOL` dx1 `appOL` dx
|
|
|
2708
|
+-- ; pprTrace "specHeader" (vcat [ text "dict_arg" <+> ppr dict_arg
|
|
|
2709
|
+-- , text "tv_bndrs" <+> ppr tv_bndrs
|
|
|
2710
|
+-- , text "tv_binds" <+> ppr tv_binds
|
|
|
2711
|
+-- , text "in_scope" <+> ppr (substInScopeSet subst4) ]) $
|
|
|
2712
|
+-- return ()
|
|
2706
|
2713
|
; pure ( True, subst4 -- Ha! A useful specialisation!
|
|
2707
|
2714
|
, bndr' : rule_bs, Var bndr' : rule_es
|
|
2708
|
2715
|
, spec_bs, dx', spec_dict : spec_args ) }
|
| ... |
... |
@@ -2733,11 +2740,14 @@ specHeader subst (bndr:bndrs) (UnspecArg : args) |
|
2733
|
2740
|
|
|
2734
|
2741
|
|
|
2735
|
2742
|
bindAuxiliaryTyVars :: Subst -> CoreExpr -> (TyVarSet, OrdList FloatBind)
|
|
|
2743
|
+-- (bindAuxiliaryTyVars subst dict_arg) returns bindings for any
|
|
|
2744
|
+-- free tyvars of dict_arg that are not in scope, but have an unfolding
|
|
|
2745
|
+-- And it return the set of precisely those tyvars, the binders of the bindings
|
|
2736
|
2746
|
bindAuxiliaryTyVars subst dict_arg
|
|
2737
|
2747
|
= go emptyVarSet need_bind_tvs
|
|
2738
|
2748
|
where
|
|
2739
|
|
- go _ []
|
|
2740
|
|
- = (emptyVarSet, nilOL)
|
|
|
2749
|
+ go tv_bndrs []
|
|
|
2750
|
+ = (tv_bndrs, nilOL)
|
|
2741
|
2751
|
go tv_bndrs (tv:tvs)
|
|
2742
|
2752
|
| tv `elemVarSet` tv_bndrs
|
|
2743
|
2753
|
= go tv_bndrs tvs
|
| ... |
... |
@@ -2749,11 +2759,11 @@ bindAuxiliaryTyVars subst dict_arg |
|
2749
|
2759
|
, child_binds `appOL` unitOL (mkDB (NonRec tv (Type unf)))
|
|
2750
|
2760
|
`appOL` rest_binds )
|
|
2751
|
2761
|
| otherwise
|
|
2752
|
|
- = pprTrace "addTyVarBindings: unxpected 1" (ppr tv $$ ppr dict_arg) $
|
|
2753
|
|
- go tv_bndrs tvs
|
|
|
2762
|
+ = pprPanic "addTyVarBindings: unxpected 1" (ppr tv $$ ppr dict_arg)
|
|
2754
|
2763
|
|
|
2755
|
2764
|
need_bind_tvs = exprSomeFreeVarsList needs_binding dict_arg
|
|
2756
|
2765
|
in_scope = substInScopeSet subst
|
|
|
2766
|
+
|
|
2757
|
2767
|
needs_binding var
|
|
2758
|
2768
|
| isGlobalVar var
|
|
2759
|
2769
|
= False
|