| ... |
... |
@@ -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,67 +1277,8 @@ specCase :: SpecEnv |
|
1277
|
1277
|
, OutId
|
|
1278
|
1278
|
, [OutAlt]
|
|
1279
|
1279
|
, UsageDetails)
|
|
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
|
|
-
|
|
|
1280
|
+-- We used to float out super class selections here,
|
|
|
1281
|
+-- but no longer do so. See Historical Note [Floating dictionaries out of cases]
|
|
1341
|
1282
|
specCase env scrut case_bndr alts
|
|
1342
|
1283
|
= do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
|
|
1343
|
1284
|
; return (scrut, case_bndr', alts', uds_alts) }
|
| ... |
... |
@@ -1414,36 +1355,36 @@ Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is, |
|
1414
|
1355
|
if we run rules in the specialiser, does it matter if we make rules "win" over
|
|
1415
|
1356
|
inlining in the Simplifier? Yes, it does! See the discussion in #21851.
|
|
1416
|
1357
|
|
|
1417
|
|
-Note [Floating dictionaries out of cases]
|
|
1418
|
|
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
1419
|
|
-Consider
|
|
|
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:
|
|
1420
|
1362
|
g = \d. case d of { MkD sc ... -> ...(f sc)... }
|
|
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
|
|
|
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
|
+
|
|
1447
|
1388
|
|
|
1448
|
1389
|
************************************************************************
|
|
1449
|
1390
|
* *
|