| ... |
... |
@@ -14,8 +14,8 @@ import GHC.Driver.Config.Diagnostic |
|
14
|
14
|
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
|
|
15
|
15
|
|
|
16
|
16
|
import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
|
|
17
|
|
-import GHC.Core.Multiplicity
|
|
18
|
|
-import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
|
|
|
17
|
+-- import GHC.Core.Multiplicity
|
|
|
18
|
+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )
|
|
19
|
19
|
import GHC.Core.Predicate
|
|
20
|
20
|
import GHC.Core.Coercion( Coercion )
|
|
21
|
21
|
import GHC.Core.Opt.Monad
|
| ... |
... |
@@ -66,6 +66,8 @@ import GHC.Core.Unfold |
|
66
|
66
|
import Data.List( partition )
|
|
67
|
67
|
import Data.List.NonEmpty ( NonEmpty (..) )
|
|
68
|
68
|
import GHC.Core.Subst (substTickish)
|
|
|
69
|
+import GHC.Core.TyCon (tyConClass_maybe)
|
|
|
70
|
+import GHC.Core.DataCon (dataConTyCon)
|
|
69
|
71
|
|
|
70
|
72
|
{-
|
|
71
|
73
|
************************************************************************
|
| ... |
... |
@@ -1278,7 +1280,8 @@ specCase :: SpecEnv |
|
1278
|
1280
|
, UsageDetails)
|
|
1279
|
1281
|
specCase env scrut' case_bndr [Alt con args rhs]
|
|
1280
|
1282
|
| -- See Note [Floating dictionaries out of cases]
|
|
1281
|
|
- interestingDict scrut' (idType case_bndr)
|
|
|
1283
|
+ -- interestingDict scrut' (idType case_bndr)
|
|
|
1284
|
+ interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut'
|
|
1282
|
1285
|
, not (isDeadBinder case_bndr && null sc_args')
|
|
1283
|
1286
|
= do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
|
|
1284
|
1287
|
|
| ... |
... |
@@ -3061,9 +3064,10 @@ mkCallUDs' env f args |
|
3061
|
3064
|
-- For "invisibleFunArg", which are the type-class dictionaries,
|
|
3062
|
3065
|
-- we decide on a case by case basis if we want to specialise
|
|
3063
|
3066
|
-- on this argument; if so, SpecDict, if not UnspecArg
|
|
3064
|
|
- mk_spec_arg arg (Anon pred af)
|
|
|
3067
|
+ mk_spec_arg arg (Anon _pred af)
|
|
3065
|
3068
|
| isInvisibleFunArg af
|
|
3066
|
|
- , interestingDict arg (scaledThing pred)
|
|
|
3069
|
+ , interestingDict (ISE emptyInScopeSet realIdUnfolding) arg
|
|
|
3070
|
+ -- , interestingDict arg (scaledThing pred)
|
|
3067
|
3071
|
-- See Note [Interesting dictionary arguments]
|
|
3068
|
3072
|
= SpecDict arg
|
|
3069
|
3073
|
|
| ... |
... |
@@ -3169,33 +3173,47 @@ in the NonRec case of specBind. (This is too exotic to trouble with |
|
3169
|
3173
|
the Rec case.)
|
|
3170
|
3174
|
-}
|
|
3171
|
3175
|
|
|
3172
|
|
-interestingDict :: CoreExpr -> Type -> Bool
|
|
|
3176
|
+-- interestingDict :: CoreExpr -> Type -> Bool
|
|
|
3177
|
+interestingDict :: InScopeEnv -> CoreExpr -> Bool
|
|
3173
|
3178
|
-- A dictionary argument is interesting if it has *some* structure,
|
|
3174
|
3179
|
-- see Note [Interesting dictionary arguments]
|
|
3175
|
3180
|
-- NB: "dictionary" arguments include constraints of all sorts,
|
|
3176
|
3181
|
-- including equality constraints; hence the Coercion case
|
|
3177
|
3182
|
-- To make this work, we need to ensure that dictionaries have
|
|
3178
|
3183
|
-- unfoldings in them.
|
|
3179
|
|
-interestingDict arg _arg_ty
|
|
3180
|
|
- -- No benefit to specalizing for a ~# b I believe
|
|
3181
|
|
- -- | (isEqPred arg_ty) = False
|
|
3182
|
|
- -- |
|
|
3183
|
|
- -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
|
|
3184
|
|
- | otherwise = go arg
|
|
3185
|
|
- where
|
|
3186
|
|
- go (Var v) = hasSomeUnfolding (idUnfolding v)
|
|
3187
|
|
- || isDataConWorkId v
|
|
3188
|
|
- go (Type _) = False
|
|
3189
|
|
- go (Coercion _) = False
|
|
3190
|
|
- go (App fn (Type _)) = go fn
|
|
3191
|
|
- go (App fn (Coercion _)) = go fn
|
|
3192
|
|
- go (Tick _ a) = go a
|
|
3193
|
|
- go (Cast e _) = go e
|
|
3194
|
|
- go (Lit{}) = True
|
|
3195
|
|
- go (Case{}) = True
|
|
3196
|
|
- go (Let{}) = True
|
|
3197
|
|
- go (App{}) = True
|
|
3198
|
|
- go (Lam{}) = True
|
|
|
3184
|
+interestingDict env (Cast arg _)
|
|
|
3185
|
+ = interestingDict env arg
|
|
|
3186
|
+interestingDict env arg
|
|
|
3187
|
+ | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg
|
|
|
3188
|
+ , Just cls <- tyConClass_maybe (dataConTyCon data_con)
|
|
|
3189
|
+ , (not . isIPLikePred) (exprType arg)
|
|
|
3190
|
+ = if isCTupleClass cls
|
|
|
3191
|
+ then any (interestingDict env) args
|
|
|
3192
|
+ else True
|
|
|
3193
|
+ | otherwise
|
|
|
3194
|
+ = False
|
|
|
3195
|
+
|
|
|
3196
|
+
|
|
|
3197
|
+-- interestingDict arg _arg_ty
|
|
|
3198
|
+-- -- No benefit to specalizing for a ~# b I believe
|
|
|
3199
|
+-- -- | (isEqPred arg_ty) = False
|
|
|
3200
|
+-- -- |
|
|
|
3201
|
+-- -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
|
|
|
3202
|
+-- | otherwise = go arg
|
|
|
3203
|
+-- where
|
|
|
3204
|
+-- go (Var v) = hasSomeUnfolding (idUnfolding v)
|
|
|
3205
|
+-- || isDataConWorkId v
|
|
|
3206
|
+-- go (Type _) = False
|
|
|
3207
|
+-- go (Coercion _) = False
|
|
|
3208
|
+-- go (App fn (Type _)) = go fn
|
|
|
3209
|
+-- go (App fn (Coercion _)) = go fn
|
|
|
3210
|
+-- go (Tick _ a) = go a
|
|
|
3211
|
+-- go (Cast e _) = go e
|
|
|
3212
|
+-- go (Lit{}) = True
|
|
|
3213
|
+-- go (Case{}) = True
|
|
|
3214
|
+-- go (Let{}) = True
|
|
|
3215
|
+-- go (App{}) = True
|
|
|
3216
|
+-- go (Lam{}) = True
|
|
3199
|
3217
|
|
|
3200
|
3218
|
-- go _ = True
|
|
3201
|
3219
|
|