diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2020-04-15 20:59:24 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-04-15 21:15:07 -0400 |
| commit | fd23f36f62658ad4ce7ffc81c4c1f11a6081a505 (patch) | |
| tree | 74161409d68ed3e6710314b12ea496077bdb7dd7 | |
| parent | 446517026d8c96a64a13fed29d655de64d33c719 (diff) | |
| download | haskell-fd23f36f62658ad4ce7ffc81c4c1f11a6081a505.tar.gz | |
Fix it
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Lint.hs | 4 |
2 files changed, 13 insertions, 7 deletions
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 35a5440967..ba51226111 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -857,13 +857,15 @@ cpeApp top_env expr _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1 -- See Note [CorePrep handling of keepAlive#] - cpe_app env (Var f) [CpeApp (Type _arg_rep), CpeApp (Type arg_ty), + cpe_app env (Var f) [CpeApp (Type arg_rep), CpeApp (Type arg_ty), CpeApp (Type result_rep), CpeApp (Type result_ty), CpeApp x, CpeApp k, CpeApp s0] 3 | f `hasKey` keepAliveIdKey = do { let voidRepTy = primRepToRuntimeRep VoidRep - ; b0 <- newVar $ mkTyConApp (tupleTyCon Unboxed 2) - [voidRepTy, result_rep, realWorldStatePrimTy, result_ty] + -- out_ty ~ (# State# RealWorld, a #) + out_ty = mkTyConApp (tupleTyCon Unboxed 2) + [voidRepTy, result_rep, realWorldStatePrimTy, result_ty] + ; b0 <- newVar out_ty ; y <- newVar result_ty ; s1 <- newVar realWorldStatePrimTy ; s2 <- newVar realWorldStatePrimTy @@ -875,9 +877,11 @@ cpeApp top_env expr stateResultAlt stateVar resultVar rhs = (DataAlt (tupleDataCon Unboxed 2), [stateVar, resultVar], rhs) - expr = Case (App k s0) b0 (varType b0) [stateResultAlt s1 y rhs1] - rhs1 = Case (mkApps (Var touchId) [Type arg_ty, x, Var s1]) s1 (varType s1) [(DEFAULT, [], rhs2)] - rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Var s2, Var y] + expr = Case (App k s0) b0 out_ty [stateResultAlt s1 y rhs1] + rhs1 = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, x, Var s1] + in Case scrut s2 out_ty [(DEFAULT, [], rhs2)] + rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) + [mkTyArg voidRepTy, mkTyArg result_rep, mkTyArg realWorldStatePrimTy, mkTyArg result_ty, Var s2, Var y] ; cpeBody env expr } cpe_app _env (Var f) args _ diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index bf4cfce443..2f5fd8810c 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -104,7 +104,9 @@ lintStgArg (StgLitArg _) = return () lintStgArg (StgVarArg v) = lintStgVar v lintStgVar :: Id -> LintM () -lintStgVar id = checkInScope id +lintStgVar id + | id `hasKey` keepAliveIdKey = addErrL (text "keepAlive# not permitted in STG") + | otherwise = checkInScope id lintStgBinds :: (OutputablePass a, BinderP a ~ Id) |