|
|
1
|
+{-# LANGUAGE MultiWayIf #-}
|
|
|
2
|
+
|
|
1
|
3
|
{-
|
|
2
|
4
|
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
|
|
3
|
5
|
|
| ... |
... |
@@ -14,7 +16,6 @@ import GHC.Driver.Config.Diagnostic |
|
14
|
16
|
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
|
|
15
|
17
|
|
|
16
|
18
|
import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
|
|
17
|
|
--- import GHC.Core.Multiplicity
|
|
18
|
19
|
import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )
|
|
19
|
20
|
import GHC.Core.Predicate
|
|
20
|
21
|
import GHC.Core.Class( classMethods )
|
| ... |
... |
@@ -3072,7 +3073,7 @@ mkCallUDs' env f args |
|
3072
|
3073
|
emptyUDs
|
|
3073
|
3074
|
|
|
3074
|
3075
|
where
|
|
3075
|
|
- _trace_doc = vcat [ppr f, ppr args, ppr ci_key, ppr (se_subst env)]
|
|
|
3076
|
+ _trace_doc = vcat [ppr f, ppr args, ppr ci_key]
|
|
3076
|
3077
|
pis = fst $ splitPiTys $ idType f
|
|
3077
|
3078
|
constrained_tyvars = tyCoVarsOfTypes $ getTheta pis
|
|
3078
|
3079
|
|
| ... |
... |
@@ -3097,7 +3098,7 @@ mkCallUDs' env f args |
|
3097
|
3098
|
-- on this argument; if so, SpecDict, if not UnspecArg
|
|
3098
|
3099
|
mk_spec_arg arg (Anon _pred af)
|
|
3099
|
3100
|
| isInvisibleFunArg af
|
|
3100
|
|
- , interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) arg
|
|
|
3101
|
+ , interestingDict env arg
|
|
3101
|
3102
|
-- , interestingDict arg (scaledThing pred)
|
|
3102
|
3103
|
-- See Note [Interesting dictionary arguments]
|
|
3103
|
3104
|
= SpecDict arg
|
| ... |
... |
@@ -3121,7 +3122,7 @@ site, so we only look through ticks that RULE matching looks through |
|
3121
|
3122
|
-}
|
|
3122
|
3123
|
|
|
3123
|
3124
|
wantCallsFor :: SpecEnv -> Id -> Bool
|
|
3124
|
|
-wantCallsFor _env _f = True
|
|
|
3125
|
+wantCallsFor _env f = not (isDataConId f) -- Better version coming in !14242
|
|
3125
|
3126
|
-- We could reduce the size of the UsageDetails by being less eager
|
|
3126
|
3127
|
-- about collecting calls for LocalIds: there is no point for
|
|
3127
|
3128
|
-- ones that are lambda-bound. We can't decide this by looking at
|
| ... |
... |
@@ -3177,7 +3178,7 @@ case we can clearly specialise. But there are wrinkles: |
|
3177
|
3178
|
whole it's only a small win: 2.2% improvement in allocation for ansi,
|
|
3178
|
3179
|
1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
|
|
3179
|
3180
|
|
|
3180
|
|
-(ID4) We must be very careful not to specialise on a "dictionry" that is, or contains
|
|
|
3181
|
+(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
|
|
3181
|
3182
|
an implicit parameter, because implicit parameters are emphatically not singleton
|
|
3182
|
3183
|
types. See #25999:
|
|
3183
|
3184
|
useImplicit :: (?i :: Int) => Int
|
| ... |
... |
@@ -3247,24 +3248,41 @@ in the NonRec case of specBind. (This is too exotic to trouble with |
|
3247
|
3248
|
the Rec case.)
|
|
3248
|
3249
|
-}
|
|
3249
|
3250
|
|
|
3250
|
|
-interestingDict :: InScopeEnv -> CoreExpr -> Bool
|
|
|
3251
|
+interestingDict :: SpecEnv -> CoreExpr -> Bool
|
|
|
3252
|
+-- This is a subtle and important function
|
|
3251
|
3253
|
-- See Note [Interesting dictionary arguments]
|
|
3252
|
3254
|
interestingDict env (Var v) -- See (ID3) and (ID5)
|
|
3253
|
3255
|
| Just rhs <- expandUnfolding_maybe (idUnfolding v)
|
|
3254
|
3256
|
= interestingDict env rhs
|
|
3255
|
|
-interestingDict env (Cast arg _) -- See (ID5)
|
|
3256
|
|
- = interestingDict env arg
|
|
|
3257
|
+
|
|
3257
|
3258
|
interestingDict env arg -- Main Plan: use exprIsConApp_maybe
|
|
3258
|
|
- | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg
|
|
|
3259
|
+ | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
|
|
3259
|
3260
|
, Just cls <- tyConClass_maybe (dataConTyCon data_con)
|
|
3260
|
|
- , (not . couldBeIPLike) (exprType arg) -- See (ID4)
|
|
3261
|
|
- = if null (classMethods cls) -- See (ID6)
|
|
|
3261
|
+ , (not . couldBeIPLike) arg_ty -- See (ID4)
|
|
|
3262
|
+ = if null (classMethods cls) -- See (ID6)
|
|
3262
|
3263
|
then any (interestingDict env) args
|
|
3263
|
3264
|
else True
|
|
3264
|
|
- | exprIsHNF arg -- See (ID7)
|
|
3265
|
|
- = True
|
|
|
3265
|
+
|
|
|
3266
|
+ | Cast inner_arg _ <- arg -- See (ID5)
|
|
|
3267
|
+ = if | isConstraintKind $ typeKind $ exprType inner_arg
|
|
|
3268
|
+ -- If coercions were always homo-kinded, we'd know
|
|
|
3269
|
+ -- that this would be the only case
|
|
|
3270
|
+ -> interestingDict env inner_arg
|
|
|
3271
|
+
|
|
|
3272
|
+ -- Cheeck for an implicit parameter
|
|
|
3273
|
+ | Just (cls,_) <- getClassPredTys_maybe arg_ty
|
|
|
3274
|
+ , isIPClass cls -- See (ID4)
|
|
|
3275
|
+ -> False
|
|
|
3276
|
+
|
|
|
3277
|
+ -- Otherwise we are unwrapping a unary type class
|
|
|
3278
|
+ | otherwise
|
|
|
3279
|
+ -> exprIsHNF arg -- See (ID7)
|
|
|
3280
|
+
|
|
3266
|
3281
|
| otherwise
|
|
3267
|
3282
|
= False
|
|
|
3283
|
+ where
|
|
|
3284
|
+ arg_ty = exprType arg
|
|
|
3285
|
+ in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
|
|
3268
|
3286
|
|
|
3269
|
3287
|
thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
|
|
3270
|
3288
|
thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
|