| ... |
... |
@@ -64,7 +64,7 @@ import GHC.Unit.Module.ModGuts |
|
64
|
64
|
import GHC.Core.Unfold
|
|
65
|
65
|
|
|
66
|
66
|
import Data.List( partition )
|
|
67
|
|
--- import Data.List.NonEmpty ( NonEmpty (..) )
|
|
|
67
|
+import Data.List.NonEmpty ( NonEmpty (..) )
|
|
68
|
68
|
import GHC.Core.Subst (substTickish)
|
|
69
|
69
|
|
|
70
|
70
|
{-
|
| ... |
... |
@@ -1277,8 +1277,67 @@ specCase :: SpecEnv |
|
1277
|
1277
|
, OutId
|
|
1278
|
1278
|
, [OutAlt]
|
|
1279
|
1279
|
, UsageDetails)
|
|
1280
|
|
--- We used to float out super class selections here,
|
|
1281
|
|
--- but no longer do so. See Historical Note [Floating dictionaries out of cases]
|
|
|
1280
|
+specCase env scrut' case_bndr [Alt con args rhs]
|
|
|
1281
|
+ | -- See Note [Floating dictionaries out of cases]
|
|
|
1282
|
+ interestingDict scrut' (idType case_bndr)
|
|
|
1283
|
+ , not (isDeadBinder case_bndr && null sc_args')
|
|
|
1284
|
+ = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
|
|
|
1285
|
+
|
|
|
1286
|
+ ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
|
|
|
1287
|
+ scrut_bind = mkDB (NonRec case_bndr_flt scrut')
|
|
|
1288
|
+
|
|
|
1289
|
+ sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss
|
|
|
1290
|
+ sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')
|
|
|
1291
|
+ [Alt con args' (Var sc_arg')]
|
|
|
1292
|
+ | sc_arg' <- sc_args' ]
|
|
|
1293
|
+ cb_set = unitVarSet case_bndr_flt'
|
|
|
1294
|
+ sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set }
|
|
|
1295
|
+ | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]
|
|
|
1296
|
+
|
|
|
1297
|
+ flt_binds = scrut_bind : sc_binds
|
|
|
1298
|
+
|
|
|
1299
|
+ -- Extend the substitution for RHS to map the *original* binders
|
|
|
1300
|
+ -- to their floated versions.
|
|
|
1301
|
+ mb_sc_flts :: [Maybe DictId]
|
|
|
1302
|
+ mb_sc_flts = map (lookupVarEnv clone_env) args'
|
|
|
1303
|
+ clone_env = zipVarEnv sc_args' sc_args_flt'
|
|
|
1304
|
+
|
|
|
1305
|
+ subst_prs = (case_bndr, Var case_bndr_flt)
|
|
|
1306
|
+ : [ (arg, Var sc_flt)
|
|
|
1307
|
+ | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
|
|
|
1308
|
+ subst' = se_subst env_rhs
|
|
|
1309
|
+ `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')
|
|
|
1310
|
+ `Core.extendIdSubstList` subst_prs
|
|
|
1311
|
+ env_rhs' = env_rhs { se_subst = subst' }
|
|
|
1312
|
+
|
|
|
1313
|
+ ; (rhs', rhs_uds) <- specExpr env_rhs' rhs
|
|
|
1314
|
+ ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
|
|
|
1315
|
+ all_uds = flt_binds `consDictBinds` free_uds
|
|
|
1316
|
+ alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')
|
|
|
1317
|
+-- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
|
|
|
1318
|
+ ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
|
|
|
1319
|
+ where
|
|
|
1320
|
+ (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
|
|
|
1321
|
+ sc_args' = filter is_flt_sc_arg args'
|
|
|
1322
|
+
|
|
|
1323
|
+ clone_me bndr = do { uniq <- getUniqueM
|
|
|
1324
|
+ ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
|
|
|
1325
|
+ where
|
|
|
1326
|
+ name = idName bndr
|
|
|
1327
|
+ wght = idMult bndr
|
|
|
1328
|
+ ty = idType bndr
|
|
|
1329
|
+ occ = nameOccName name
|
|
|
1330
|
+ loc = getSrcSpan name
|
|
|
1331
|
+
|
|
|
1332
|
+ arg_set = mkVarSet args'
|
|
|
1333
|
+ is_flt_sc_arg var = isId var
|
|
|
1334
|
+ && not (isDeadBinder var)
|
|
|
1335
|
+ && isDictTy var_ty
|
|
|
1336
|
+ && tyCoVarsOfType var_ty `disjointVarSet` arg_set
|
|
|
1337
|
+ where
|
|
|
1338
|
+ var_ty = idType var
|
|
|
1339
|
+
|
|
|
1340
|
+
|
|
1282
|
1341
|
specCase env scrut case_bndr alts
|
|
1283
|
1342
|
= do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
|
|
1284
|
1343
|
; return (scrut, case_bndr', alts', uds_alts) }
|
| ... |
... |
@@ -1355,36 +1414,36 @@ Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is, |
|
1355
|
1414
|
if we run rules in the specialiser, does it matter if we make rules "win" over
|
|
1356
|
1415
|
inlining in the Simplifier? Yes, it does! See the discussion in #21851.
|
|
1357
|
1416
|
|
|
1358
|
|
-Historical Note [Floating dictionaries out of cases]
|
|
1359
|
|
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
1360
|
|
-Function `specCase` used to give special treatment to a case-expression
|
|
1361
|
|
-that scrutinised a dictionary, like this:
|
|
|
1417
|
+Note [Floating dictionaries out of cases]
|
|
|
1418
|
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
1419
|
+Consider
|
|
1362
|
1420
|
g = \d. case d of { MkD sc ... -> ...(f sc)... }
|
|
1363
|
|
-But actually
|
|
1364
|
|
-
|
|
1365
|
|
-* We never explicitly case-analyse a dictionary; rather the class-op
|
|
1366
|
|
- rules select superclasses from it. (NB: worker/wrapper can unbox
|
|
1367
|
|
- tuple dictionaries -- see (DNB1) in Note [Do not unbox class dictionaries];
|
|
1368
|
|
- but that's only after worker/wrapper, and specialisation happens before
|
|
1369
|
|
- that.)
|
|
1370
|
|
-
|
|
1371
|
|
-* Calling `interestingDict` on every scrutinee is hardly sensible;
|
|
1372
|
|
- generally `interestingDict` is called only on Constraint-kinded things.
|
|
1373
|
|
-
|
|
1374
|
|
-* It was giving a Lint scope error in !14272
|
|
1375
|
|
-
|
|
1376
|
|
-So now there is no special case. This Note just records the change
|
|
1377
|
|
-in case we ever want to reinstate it. The original note was
|
|
1378
|
|
-added in
|
|
1379
|
|
-
|
|
1380
|
|
- commit c107a00ccf1e641a2d008939cf477c71caa028d5
|
|
1381
|
|
- Author: Simon Peyton Jones <simonpj@microsoft.com>
|
|
1382
|
|
- Date: Thu Aug 12 13:11:33 2010 +0000
|
|
1383
|
|
-
|
|
1384
|
|
- Improve the Specialiser, fixing Trac #4203
|
|
1385
|
|
-
|
|
1386
|
|
-End of Historical Note
|
|
1387
|
|
-
|
|
|
1421
|
+Naively we can't float d2's binding out of the case expression,
|
|
|
1422
|
+because 'sc' is bound by the case, and that in turn means we can't
|
|
|
1423
|
+specialise f, which seems a pity.
|
|
|
1424
|
+
|
|
|
1425
|
+So we invert the case, by floating out a binding
|
|
|
1426
|
+for 'sc_flt' thus:
|
|
|
1427
|
+ sc_flt = case d of { MkD sc ... -> sc }
|
|
|
1428
|
+Now we can float the call instance for 'f'. Indeed this is just
|
|
|
1429
|
+what'll happen if 'sc' was originally bound with a let binding,
|
|
|
1430
|
+but case is more efficient, and necessary with equalities. So it's
|
|
|
1431
|
+good to work with both.
|
|
|
1432
|
+
|
|
|
1433
|
+You might think that this won't make any difference, because the
|
|
|
1434
|
+call instance will only get nuked by the \d. BUT if 'g' itself is
|
|
|
1435
|
+specialised, then transitively we should be able to specialise f.
|
|
|
1436
|
+
|
|
|
1437
|
+In general, given
|
|
|
1438
|
+ case e of cb { MkD sc ... -> ...(f sc)... }
|
|
|
1439
|
+we transform to
|
|
|
1440
|
+ let cb_flt = e
|
|
|
1441
|
+ sc_flt = case cb_flt of { MkD sc ... -> sc }
|
|
|
1442
|
+ in
|
|
|
1443
|
+ case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
|
|
|
1444
|
+
|
|
|
1445
|
+The "_flt" things are the floated binds; we use the current substitution
|
|
|
1446
|
+to substitute sc -> sc_flt in the RHS
|
|
1388
|
1447
|
|
|
1389
|
1448
|
************************************************************************
|
|
1390
|
1449
|
* *
|