| ... |
... |
@@ -31,7 +31,7 @@ import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable |
|
31
|
31
|
import GHC.Core.FVs
|
|
32
|
32
|
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
|
|
33
|
33
|
import GHC.Core.Opt.Arity( collectBindersPushingCo )
|
|
34
|
|
--- import GHC.Core.Ppr( pprIds )
|
|
|
34
|
+import GHC.Core.Ppr( pprIds )
|
|
35
|
35
|
|
|
36
|
36
|
import GHC.Builtin.Types ( unboxedUnitTy )
|
|
37
|
37
|
|
| ... |
... |
@@ -1701,21 +1701,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
|
1701
|
1701
|
, rule_bndrs, rule_lhs_args
|
|
1702
|
1702
|
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
|
|
1703
|
1703
|
|
|
1704
|
|
--- ; pprTrace "spec_call" (vcat
|
|
1705
|
|
--- [ text "fun: " <+> ppr fn
|
|
1706
|
|
--- , text "call info: " <+> ppr _ci
|
|
1707
|
|
--- , text "useful: " <+> ppr useful
|
|
1708
|
|
--- , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
1709
|
|
--- , text "lhs_args: " <+> ppr rule_lhs_args
|
|
1710
|
|
--- , text "spec_bndrs1:" <+> ppr spec_bndrs1
|
|
1711
|
|
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
|
|
1712
|
|
--- , text "spec_args: " <+> ppr spec_args
|
|
1713
|
|
--- , text "dx_binds: " <+> ppr dx_binds
|
|
1714
|
|
--- , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
1715
|
|
--- , text "rhs_body" <+> ppr rhs_body
|
|
1716
|
|
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
|
|
1717
|
|
--- , ppr dx_binds ]) $
|
|
1718
|
|
--- return ()
|
|
|
1704
|
+ ; pprTrace "spec_call" (vcat
|
|
|
1705
|
+ [ text "fun: " <+> ppr fn
|
|
|
1706
|
+ , text "call info: " <+> ppr _ci
|
|
|
1707
|
+ , text "useful: " <+> ppr useful
|
|
|
1708
|
+ , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
|
1709
|
+ , text "lhs_args: " <+> ppr rule_lhs_args
|
|
|
1710
|
+ , text "spec_bndrs1:" <+> ppr spec_bndrs1
|
|
|
1711
|
+ , text "leftover_bndrs:" <+> pprIds leftover_bndrs
|
|
|
1712
|
+ , text "spec_args: " <+> ppr spec_args
|
|
|
1713
|
+ , text "dx_binds: " <+> ppr dx_binds
|
|
|
1714
|
+ , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
|
1715
|
+ , text "rhs_body" <+> ppr rhs_body
|
|
|
1716
|
+ , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
|
|
|
1717
|
+ , ppr dx_binds ]) $
|
|
|
1718
|
+ return ()
|
|
1719
|
1719
|
|
|
1720
|
1720
|
; if not useful -- No useful specialisation
|
|
1721
|
1721
|
|| already_covered rhs_env2 rules_acc rule_lhs_args
|
| ... |
... |
@@ -3178,8 +3178,9 @@ interestingDict :: CoreExpr -> Type -> Bool |
|
3178
|
3178
|
-- unfoldings in them.
|
|
3179
|
3179
|
interestingDict arg arg_ty
|
|
3180
|
3180
|
-- No benefit to specalizing for a ~# b I believe
|
|
3181
|
|
- | not (isEqPred arg_ty) = False
|
|
3182
|
|
- -- | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
|
|
|
3181
|
+ -- | (isEqPred arg_ty) = False
|
|
|
3182
|
+ -- |
|
|
|
3183
|
+ -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
|
|
3183
|
3184
|
| otherwise = go arg
|
|
3184
|
3185
|
where
|
|
3185
|
3186
|
go (Var v) = hasSomeUnfolding (idUnfolding v)
|