| ... |
... |
@@ -1283,9 +1283,8 @@ simplExprF1 env expr@(Lam {}) cont |
|
1283
|
1283
|
-- and likewise drop counts all binders (incl type lambdas)
|
|
1284
|
1284
|
|
|
1285
|
1285
|
simplExprF1 env expr@(Case scrut bndr _ alts) cont
|
|
1286
|
|
- | not (seCaseCase env) -- See (COC-INV) in Note [sm_case_case: switching off case continuations]
|
|
1287
|
|
- , (inner, outer) <- splitContArgs cont
|
|
1288
|
|
- , not (contIsStop outer)
|
|
|
1286
|
+ | Just (inner, outer) <- splitContForNoCaseCase env cont
|
|
|
1287
|
+ -- See (COC-INV) in Note [sm_case_case: switching off case continuations]
|
|
1289
|
1288
|
= do { expr' <- simplExprC env expr inner
|
|
1290
|
1289
|
; rebuild env expr' outer }
|
|
1291
|
1290
|
|
| ... |
... |
@@ -1312,9 +1311,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont |
|
1312
|
1311
|
; simplExprF env' body cont }
|
|
1313
|
1312
|
|
|
1314
|
1313
|
simplExprF1 env expr@(Let {}) cont
|
|
1315
|
|
- | not (seCaseCase env)
|
|
1316
|
|
- , (inner, outer) <- splitContArgs cont
|
|
1317
|
|
- , not (contIsStop outer)
|
|
|
1314
|
+ | Just (inner, outer) <- splitContForNoCaseCase env cont
|
|
1318
|
1315
|
= do { expr' <- simplExprC env expr inner
|
|
1319
|
1316
|
; rebuild env expr' outer }
|
|
1320
|
1317
|
|
| ... |
... |
@@ -1340,6 +1337,18 @@ simplExprF1 env (Let (Rec pairs) body) cont |
|
1340
|
1337
|
simplRecE env pairs body cont
|
|
1341
|
1338
|
|
|
1342
|
1339
|
|
|
|
1340
|
+splitContForNoCaseCase :: SimplEnv -> SimplCont
|
|
|
1341
|
+ -> Maybe (SimplCont, SimplCont)
|
|
|
1342
|
+-- Splits `cont` into (inner, outer), where `inner` has only
|
|
|
1343
|
+-- applications, and `outer` is non-trivial
|
|
|
1344
|
+splitContForNoCaseCase env cont
|
|
|
1345
|
+ | not (seCaseCase env)
|
|
|
1346
|
+ , (inner, outer) <- splitContArgs cont
|
|
|
1347
|
+ , not (contIsStop outer)
|
|
|
1348
|
+ = Just (inner, outer)
|
|
|
1349
|
+ | otherwise
|
|
|
1350
|
+ = Nothing
|
|
|
1351
|
+
|
|
1343
|
1352
|
{- Note [Avoiding space leaks in OutType]
|
|
1344
|
1353
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
1345
|
1354
|
Since the simplifier is run for multiple iterations, we need to ensure
|
| ... |
... |
@@ -2403,43 +2412,13 @@ simplOutId env fun cont |
|
2403
|
2412
|
| fun `hasKey` runRWKey
|
|
2404
|
2413
|
, ApplyToTy { sc_cont = cont1 } <- cont
|
|
2405
|
2414
|
, ApplyToTy { sc_cont = cont2 } <- cont1
|
|
2406
|
|
- , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_cast = arg_mco
|
|
2407
|
|
- , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2
|
|
2408
|
|
- -- Do this even if (contIsStop cont), or if seCaseCase is off.
|
|
2409
|
|
- -- See Note [No eta-expansion in runRW#]
|
|
2410
|
|
- = do { let (_saf,arg_env) = mkAltEnv env arg_se
|
|
2411
|
|
-
|
|
2412
|
|
- overall_res_ty = contResultType cont3
|
|
2413
|
|
- -- hole_ty is the type of the current runRW# application
|
|
2414
|
|
-
|
|
2415
|
|
- -- If the argument is a literal lambda already, take a short cut
|
|
2416
|
|
- -- This isn't just efficiency:
|
|
2417
|
|
- -- * If we don't do this we get a beta-redex every time, so the
|
|
2418
|
|
- -- simplifier keeps doing more iterations.
|
|
2419
|
|
- -- * Even more important: see Note [No eta-expansion in runRW#]
|
|
2420
|
|
- ; arg' <- case arg of
|
|
2421
|
|
- Lam s body -> do { (env', s') <- simplBinder arg_env s
|
|
2422
|
|
- ; body' <- simplExprC env' body cont3
|
|
2423
|
|
- ; return (Lam s' body') }
|
|
2424
|
|
- -- Important: do not try to eta-expand this lambda
|
|
2425
|
|
- -- See Note [No eta-expansion in runRW#]
|
|
2426
|
|
-
|
|
2427
|
|
- _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
|
|
2428
|
|
- ; let (m,_,_) = splitFunTy fun_ty
|
|
2429
|
|
- env' = arg_env `addNewInScopeIds` [s']
|
|
2430
|
|
- hole_ty = mkVisFunTy m realWorldStatePrimTy overall_res_ty
|
|
2431
|
|
- ; cont' <- pushCastMCo env' arg_mco $
|
|
2432
|
|
- ApplyToVal { sc_arg = Var s', sc_cast = MRefl
|
|
2433
|
|
- , sc_env = Simplified OkDup
|
|
2434
|
|
- , sc_cont = cont3
|
|
2435
|
|
- , sc_hole_ty = hole_ty }
|
|
2436
|
|
- -- cont' applies to s', then K
|
|
2437
|
|
- ; body' <- simplExprC env' arg cont'
|
|
2438
|
|
- ; return (Lam s' body') }
|
|
2439
|
|
-
|
|
2440
|
|
- ; let rr' = getRuntimeRep overall_res_ty
|
|
2441
|
|
- call' = mkApps (Var fun) [mkTyArg rr', mkTyArg overall_res_ty, arg']
|
|
2442
|
|
- ; return (emptyFloats env, call') }
|
|
|
2415
|
+ , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_env = arg_se
|
|
|
2416
|
+ , sc_cast = arg_mco, sc_hole_ty = fun_ty } <- cont2
|
|
|
2417
|
+ = case splitContForNoCaseCase env cont3 of
|
|
|
2418
|
+ Nothing -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty cont3
|
|
|
2419
|
+ ; return (emptyFloats env, e') }
|
|
|
2420
|
+ Just (ink,outk) -> do { e' <- simplRunRW env fun arg arg_se arg_mco fun_ty ink
|
|
|
2421
|
+ ; rebuild env e' outk }
|
|
2443
|
2422
|
|
|
2444
|
2423
|
-- Normal case for (f e1 .. en)
|
|
2445
|
2424
|
simplOutId env fun cont
|
| ... |
... |
@@ -2474,6 +2453,51 @@ simplOutId env fun cont |
|
2474
|
2453
|
; rebuildCall env arg_info cont
|
|
2475
|
2454
|
} } } } }
|
|
2476
|
2455
|
|
|
|
2456
|
+simplRunRW :: SimplEnv
|
|
|
2457
|
+ -> OutId -- runRW#
|
|
|
2458
|
+ -> CoreExpr -- Main value argument `e` of runRW#
|
|
|
2459
|
+ -> StaticEnv -- ...and its static envt
|
|
|
2460
|
+ -> MOutCoercion -- ...and its MCoercion
|
|
|
2461
|
+ -> OutType -- Type of (runRW# @k @ty), always t1->t2
|
|
|
2462
|
+ -> SimplCont -- Continuation to push into body of `e`
|
|
|
2463
|
+ -> SimplM OutExpr
|
|
|
2464
|
+simplRunRW env fun arg arg_se arg_mco fun_ty cont
|
|
|
2465
|
+ -- Do this even if (contIsStop cont), or if seCaseCase is off.
|
|
|
2466
|
+ -- See Note [No eta-expansion in runRW#]
|
|
|
2467
|
+ = do { let (_saf,arg_env) = mkAltEnv env arg_se
|
|
|
2468
|
+
|
|
|
2469
|
+ overall_res_ty = contResultType cont
|
|
|
2470
|
+ -- hole_ty is the type of the current runRW# application
|
|
|
2471
|
+
|
|
|
2472
|
+ -- If the argument is a literal lambda already, take a short cut
|
|
|
2473
|
+ -- This isn't just efficiency:
|
|
|
2474
|
+ -- * If we don't do this we get a beta-redex every time, so the
|
|
|
2475
|
+ -- simplifier keeps doing more iterations.
|
|
|
2476
|
+ -- * Even more important: see Note [No eta-expansion in runRW#]
|
|
|
2477
|
+ ; arg' <- case arg of
|
|
|
2478
|
+ Lam s body -> do { (env', s') <- simplBinder arg_env s
|
|
|
2479
|
+ ; body' <- simplExprC env' body cont
|
|
|
2480
|
+ ; return (Lam s' body') }
|
|
|
2481
|
+ -- Important: do not try to eta-expand this lambda
|
|
|
2482
|
+ -- See Note [No eta-expansion in runRW#]
|
|
|
2483
|
+
|
|
|
2484
|
+ _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
|
|
|
2485
|
+ ; let (m,_,_) = splitFunTy fun_ty
|
|
|
2486
|
+ env' = arg_env `addNewInScopeIds` [s']
|
|
|
2487
|
+ hole_ty = mkVisFunTy m realWorldStatePrimTy overall_res_ty
|
|
|
2488
|
+ ; cont' <- pushCastMCo env' arg_mco $
|
|
|
2489
|
+ ApplyToVal { sc_arg = Var s', sc_cast = MRefl
|
|
|
2490
|
+ , sc_env = Simplified OkDup
|
|
|
2491
|
+ , sc_cont = cont
|
|
|
2492
|
+ , sc_hole_ty = hole_ty }
|
|
|
2493
|
+ -- cont' applies to s', then K
|
|
|
2494
|
+ ; body' <- simplExprC env' arg cont'
|
|
|
2495
|
+ ; return (Lam s' body') }
|
|
|
2496
|
+
|
|
|
2497
|
+ ; let rr' = getRuntimeRep overall_res_ty
|
|
|
2498
|
+ call' = mkApps (Var fun) [mkTyArg rr', mkTyArg overall_res_ty, arg']
|
|
|
2499
|
+ ; return call' }
|
|
|
2500
|
+
|
|
2477
|
2501
|
---------------------------------------------------------
|
|
2478
|
2502
|
-- Dealing with a call site
|
|
2479
|
2503
|
|