diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2020-04-15 17:23:52 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-04-15 17:23:52 -0400 |
| commit | 1938fe8e81da5bb822ceec920d91ef3e80d2272a (patch) | |
| tree | 0e9590fe1d2196a8efb028f9fa5235ba3e4fe150 | |
| parent | 62fca4e11bc315ec12b8ca077a2ede61f4676477 (diff) | |
| download | haskell-1938fe8e81da5bb822ceec920d91ef3e80d2272a.tar.gz | |
It workswip/with2
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 7 | ||||
| -rw-r--r-- | libraries/base/GHC/ForeignPtr.hs | 3 |
3 files changed, 13 insertions, 7 deletions
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index b45d23f522..35a5440967 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -855,14 +855,16 @@ cpeApp top_env expr = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0 _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1 + -- See Note [CorePrep handling of keepAlive#] - cpe_app env (Var f) [CpeApp (Type ty), CpeApp (Type runtimeRep), CpeApp (Type resultTy), + 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, runtimeRep, realWorldStatePrimTy, resultTy] - ; y <- newVar resultTy + [voidRepTy, result_rep, realWorldStatePrimTy, result_ty] + ; y <- newVar result_ty ; s1 <- newVar realWorldStatePrimTy ; s2 <- newVar realWorldStatePrimTy ; let touchId = mkPrimOpId TouchOp @@ -874,7 +876,7 @@ cpeApp top_env expr (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 ty, x, Var s1]) s1 (varType s1) [(DEFAULT, [], rhs2)] + 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] ; cpeBody env expr } diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 56739b1c91..08f43e910f 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1386,7 +1386,8 @@ seqId = pcMiscPrelId seqName ty info ------------------------------------------------ keepAliveId :: Id keepAliveId - = pcMiscPrelId keepAliveName ty id_info `setIdDetails` NoBindingId + = pcMiscPrelId keepAliveName ty id_info + `setIdDetails` NoBindingId where -- keepAlive# -- :: forall (rep_a :: RuntimeRep) (a :: TYPE rep_a) @@ -1405,7 +1406,9 @@ keepAliveId cont_ty = realWorldStatePrimTy `mkVisFunTy` result_ty -- (# State# RealWorld, r #) result_ty = mkTupleTy Unboxed [realWorldStatePrimTy, mkTyVarTy r] - id_info = noCafIdInfo `setStrictnessInfo` mkClosedStrictSig [topDmd, strictApply1Dmd, topDmd] topDiv + id_info = noCafIdInfo + `setStrictnessInfo` mkClosedStrictSig [topDmd, strictApply1Dmd, topDmd] topDiv + `setArityInfo` 3 ------------------------------------------------ lazyId :: Id -- See Note [lazyId magic] diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 6a1b3c8370..cfc783804b 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -412,7 +412,8 @@ withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -- 'Storable' class. withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s -> case f (unsafeForeignPtrToPtr fo) of - IO action# -> keepAlive# r action# s + IO action# -> keepAlive# r (\s' -> action# s') s + touchForeignPtr :: ForeignPtr a -> IO () -- ^This function ensures that the foreign object in |