| ... |
... |
@@ -66,6 +66,7 @@ import GHC.Builtin.WiredIn.Ids( seqId ) |
|
66
|
66
|
import qualified GHC.Data.List.Infinite as Inf
|
|
67
|
67
|
import GHC.Data.Maybe ( isNothing, orElse, mapMaybe )
|
|
68
|
68
|
import GHC.Data.FastString
|
|
|
69
|
+import GHC.Data.OrdList ( fromOL ) -- TMP
|
|
69
|
70
|
import GHC.Unit.Module ( moduleName )
|
|
70
|
71
|
import GHC.Utils.Outputable
|
|
71
|
72
|
import GHC.Utils.Panic
|
| ... |
... |
@@ -1285,8 +1286,8 @@ simplExprF1 env expr@(Lam {}) cont |
|
1285
|
1286
|
simplExprF1 env expr@(Case scrut bndr _ alts) cont
|
|
1286
|
1287
|
| Just (inner, outer) <- splitContForNoCaseCase env cont
|
|
1287
|
1288
|
-- See (COC-INV) in Note [sm_case_case: switching off case continuations]
|
|
1288
|
|
- = do { expr' <- simplExprC env expr inner
|
|
1289
|
|
- ; rebuild env expr' outer }
|
|
|
1289
|
+ = do { (floats, expr') <- simplExprF env expr inner
|
|
|
1290
|
+ ; rebuildWithFloats env floats expr' outer }
|
|
1290
|
1291
|
|
|
1291
|
1292
|
| otherwise
|
|
1292
|
1293
|
= {-#SCC "simplExprF1-Case" #-}
|
| ... |
... |
@@ -1312,8 +1313,9 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont |
|
1312
|
1313
|
|
|
1313
|
1314
|
simplExprF1 env expr@(Let {}) cont
|
|
1314
|
1315
|
| Just (inner, outer) <- splitContForNoCaseCase env cont
|
|
1315
|
|
- = do { expr' <- simplExprC env expr inner
|
|
1316
|
|
- ; rebuild env expr' outer }
|
|
|
1316
|
+ -- See (COC-INV) in Note [sm_case_case: switching off case continuations]
|
|
|
1317
|
+ = do { (floats, expr') <- simplExprF env expr inner
|
|
|
1318
|
+ ; rebuildWithFloats env floats expr' outer }
|
|
1317
|
1319
|
|
|
1318
|
1320
|
-- Now check for a join point. It's better to do the preInlineUnconditionally
|
|
1319
|
1321
|
-- test first, because joinPointBinding_maybe has to eta-expand, so a trivial
|
| ... |
... |
@@ -1626,6 +1628,22 @@ simplTick env tickish expr cont |
|
1626
|
1628
|
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
|
|
1627
|
1629
|
rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont
|
|
1628
|
1630
|
|
|
|
1631
|
+rebuildWithFloats :: SimplEnv -> SimplFloats -> OutExpr -> SimplCont
|
|
|
1632
|
+ -> SimplM (SimplFloats, OutExpr)
|
|
|
1633
|
+-- (rebuildWithFloats env floats expr cont) rebuilds (let floats in expr)
|
|
|
1634
|
+-- with continuation `cont`. Used only when seCaseCase is off.
|
|
|
1635
|
+-- See (COC3) in Note [sm_case_case: switching off case continuations]
|
|
|
1636
|
+rebuildWithFloats env floats expr cont
|
|
|
1637
|
+ | Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont' } <- cont
|
|
|
1638
|
+ , isEmptyJoinFloats (sfJoinFloats floats)
|
|
|
1639
|
+ , let env1 = zapSubstEnv env `setInScopeFromF` floats
|
|
|
1640
|
+ , Just do_it <- knownConCase_maybe (mkAltEnv env1 se) expr bndr alts cont'
|
|
|
1641
|
+ = do { (floats2, res) <- do_it
|
|
|
1642
|
+ ; return (floats `addFloats` floats2, res) }
|
|
|
1643
|
+
|
|
|
1644
|
+ | otherwise
|
|
|
1645
|
+ = rebuild env (wrapFloats floats expr) cont
|
|
|
1646
|
+
|
|
1629
|
1647
|
rebuild_go :: HasDebugCallStack
|
|
1630
|
1648
|
=> SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
|
|
1631
|
1649
|
-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;
|
| ... |
... |
@@ -3287,41 +3305,9 @@ rebuildCase, reallyRebuildCase |
|
3287
|
3305
|
-- 1. Eliminate the case if there's a known constructor
|
|
3288
|
3306
|
--------------------------------------------------
|
|
3289
|
3307
|
|
|
3290
|
|
-rebuildCase (saf,env) scrut case_bndr alts cont
|
|
3291
|
|
- | Lit lit <- scrut -- No need for same treatment as constructors
|
|
3292
|
|
- -- because literals are inlined more vigorously
|
|
3293
|
|
- , not (litIsLifted lit)
|
|
3294
|
|
- = do { tick (KnownBranch case_bndr)
|
|
3295
|
|
- ; case findAlt (LitAlt lit) alts of
|
|
3296
|
|
- Nothing -> missingAlt env case_bndr alts cont
|
|
3297
|
|
- Just (Alt _ bs rhs) -> simpl_rhs env scrut bs rhs }
|
|
3298
|
|
-
|
|
3299
|
|
- | Just (in_scope', wfloats, con, ty_args, other_args)
|
|
3300
|
|
- <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
|
|
3301
|
|
- -- Works when the scrutinee is a variable with a known unfolding
|
|
3302
|
|
- -- as well as when it's an explicit constructor application
|
|
3303
|
|
- , let env0 = setInScopeSet env in_scope'
|
|
3304
|
|
- = do { tick (KnownBranch case_bndr)
|
|
3305
|
|
- ; let -- case_bndr_unf: see Note [Do not duplicate constructor applications]
|
|
3306
|
|
- case_bndr_rhs | exprIsTrivial scrut = scrut
|
|
3307
|
|
- | otherwise = con_app
|
|
3308
|
|
- con_app = Var (dataConWorkId con) `mkTyApps` ty_args
|
|
3309
|
|
- `mkApps` other_args
|
|
3310
|
|
- ; wrapDataConFloats env wfloats case_bndr cont $
|
|
3311
|
|
- case findAlt (DataAlt con) alts of
|
|
3312
|
|
- Nothing -> missingAlt env0 case_bndr alts cont
|
|
3313
|
|
- Just (Alt DEFAULT bs rhs) -> simpl_rhs env0 case_bndr_rhs bs rhs
|
|
3314
|
|
- Just (Alt _ bs rhs) -> knownCon env0 scrut con other_args
|
|
3315
|
|
- case_bndr bs rhs cont
|
|
3316
|
|
- }
|
|
3317
|
|
- where
|
|
3318
|
|
- simpl_rhs env case_bndr_rhs bs rhs
|
|
3319
|
|
- = assert (null bs) $
|
|
3320
|
|
- do { (floats1, env') <- simplAuxBind (saf,env) case_bndr case_bndr_rhs
|
|
3321
|
|
- -- scrut is a constructor application,
|
|
3322
|
|
- -- hence satisfies let-can-float invariant
|
|
3323
|
|
- ; (floats2, expr') <- simplExprF env' rhs cont
|
|
3324
|
|
- ; return (floats1 `addFloats` floats2, expr') }
|
|
|
3308
|
+rebuildCase saf_env scrut case_bndr alts cont
|
|
|
3309
|
+ | Just do_it <- knownConCase_maybe saf_env scrut case_bndr alts cont
|
|
|
3310
|
+ = do_it
|
|
3325
|
3311
|
|
|
3326
|
3312
|
--------------------------------------------------
|
|
3327
|
3313
|
-- 2. Eliminate the case if scrutinee is evaluated
|
| ... |
... |
@@ -3928,6 +3914,58 @@ let binders, so we could float them). But the need for the extra |
|
3928
|
3914
|
complication is not clear.
|
|
3929
|
3915
|
-}
|
|
3930
|
3916
|
|
|
|
3917
|
+knownConCase_maybe :: (SimplAltFlag, SimplEnv)
|
|
|
3918
|
+ -> OutExpr -- Scrutinee
|
|
|
3919
|
+ -> InId -- Case binder
|
|
|
3920
|
+ -> [InAlt] -- Alternatives (increasing order)
|
|
|
3921
|
+ -> SimplCont
|
|
|
3922
|
+ -> Maybe (SimplM (SimplFloats, OutExpr))
|
|
|
3923
|
+-- Case-of-known-constructor: returns Just if the scrutinee is a literal
|
|
|
3924
|
+-- or (via exprIsConApp_maybe) a constructor application
|
|
|
3925
|
+knownConCase_maybe (saf,env) scrut case_bndr alts cont
|
|
|
3926
|
+ | Lit lit <- scrut -- No need for same treatment as constructors
|
|
|
3927
|
+ -- because literals are inlined more vigorously
|
|
|
3928
|
+ , not (litIsLifted lit)
|
|
|
3929
|
+ = Just $
|
|
|
3930
|
+ do { tick (KnownBranch case_bndr)
|
|
|
3931
|
+ ; case findAlt (LitAlt lit) alts of
|
|
|
3932
|
+ Nothing -> missingAlt env case_bndr alts cont
|
|
|
3933
|
+ Just (Alt _ bs rhs) -> simpl_rhs env scrut bs rhs }
|
|
|
3934
|
+
|
|
|
3935
|
+ | Just (in_scope', wfloats, con, ty_args, other_args)
|
|
|
3936
|
+ <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
|
|
|
3937
|
+ -- Works when the scrutinee is a variable with a known unfolding
|
|
|
3938
|
+ -- as well as when it's an explicit constructor application
|
|
|
3939
|
+ , let env0 = setInScopeSet env in_scope'
|
|
|
3940
|
+ = Just $
|
|
|
3941
|
+ (if isEmptyFloatBinds wfloats then id else
|
|
|
3942
|
+ pprTrace "TMP-knownCon" (vcat [ text "nfloats" <+> ppr (length (fromOL wfloats))
|
|
|
3943
|
+ , text "scrut" <+> ppr scrut ])) $
|
|
|
3944
|
+ do { tick (KnownBranch case_bndr)
|
|
|
3945
|
+ ; let -- case_bndr_unf: see Note [Do not duplicate constructor applications]
|
|
|
3946
|
+ case_bndr_rhs | exprIsTrivial scrut = scrut
|
|
|
3947
|
+ | otherwise = con_app
|
|
|
3948
|
+ con_app = Var (dataConWorkId con) `mkTyApps` ty_args
|
|
|
3949
|
+ `mkApps` other_args
|
|
|
3950
|
+ ; wrapDataConFloats env wfloats case_bndr cont $
|
|
|
3951
|
+ case findAlt (DataAlt con) alts of
|
|
|
3952
|
+ Nothing -> missingAlt env0 case_bndr alts cont
|
|
|
3953
|
+ Just (Alt DEFAULT bs rhs) -> simpl_rhs env0 case_bndr_rhs bs rhs
|
|
|
3954
|
+ Just (Alt _ bs rhs) -> knownCon env0 scrut con other_args
|
|
|
3955
|
+ case_bndr bs rhs cont
|
|
|
3956
|
+ }
|
|
|
3957
|
+
|
|
|
3958
|
+ | otherwise
|
|
|
3959
|
+ = Nothing
|
|
|
3960
|
+ where
|
|
|
3961
|
+ simpl_rhs env case_bndr_rhs bs rhs
|
|
|
3962
|
+ = assert (null bs) $
|
|
|
3963
|
+ do { (floats1, env') <- simplAuxBind (saf,env) case_bndr case_bndr_rhs
|
|
|
3964
|
+ -- scrut is a constructor application,
|
|
|
3965
|
+ -- hence satisfies let-can-float invariant
|
|
|
3966
|
+ ; (floats2, expr') <- simplExprF env' rhs cont
|
|
|
3967
|
+ ; return (floats1 `addFloats` floats2, expr') }
|
|
|
3968
|
+
|
|
3931
|
3969
|
wrapDataConFloats :: SimplEnv -> FloatBinds -> InId -> SimplCont
|
|
3932
|
3970
|
-> SimplM (SimplFloats, OutExpr)
|
|
3933
|
3971
|
-> SimplM (SimplFloats, OutExpr)
|