[Git][ghc/ghc][wip/keepAlive] 4 commits: Simplify
Ben Gamari
gitlab at gitlab.haskell.org
Fri Apr 24 23:34:12 UTC 2020
Ben Gamari pushed to branch wip/keepAlive at Glasgow Haskell Compiler / GHC
Commits:
27651ba2 by Ben Gamari at 2020-04-24T19:33:57-04:00
Simplify
- - - - -
4b602e59 by Ben Gamari at 2020-04-24T19:33:58-04:00
base: Use keepAlive# in withForeignPtr
- - - - -
fa62af11 by Ben Gamari at 2020-04-24T19:33:58-04:00
base: Use keepAlive# in alloca, et al.
- - - - -
03555271 by Ben Gamari at 2020-04-24T19:33:58-04:00
ghc-compact: Use keepAlive#
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- libraries/base/Foreign/ForeignPtr/Imp.hs
- libraries/base/Foreign/Marshal/Alloc.hs
- libraries/base/GHC/ForeignPtr.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -405,6 +405,7 @@ lvlApp :: LevelEnv
lvlApp env orig_expr ((_,AnnVar fn), args)
-- Try to ensure that runRW#'s continuation isn't floated out.
-- See Note [Simplification of runRW#].
+ -- TODO: update for keepAlive#
| fn `hasKey` runRWKey || fn `hasKey` keepAliveIdKey
= do { args' <- mapM (lvlExpr env) args
; return (foldl' App (lookupVar env fn) args') }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1882,59 +1882,11 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
---------- Simplify continuation-passing primops --------------
-- (Do this after absorbing all arguments)
---
--- Push strict contexts into keepAlive# continuation
---
--- That is,
---
--- K[keepAlive# @arg_rep @arg_ty @res_rep @res_ty x (\s -> rhs) s0] :: (out_ty :: TYPE out_rep)
--- ~>
--- keepAlive# @arg_rep @arg_ty @out_rep @out_ty x (\s -> K[rhs]) s0
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
- | fun `hasKey` keepAliveIdKey
- , [ ValArg y
- , ValArg x
- , TyArg {} -- res_ty
- , TyArg {} -- res_rep
- , TyArg {as_arg_ty=arg_ty}
- , TyArg {as_arg_ty=arg_rep}
- ] <- rev_args
- = do { let ty' = contResultType cont
- ; j <- newJoinId [] ty'
- ; let env' = zapSubstEnv env
- ; y' <- simplExprC env' y cont
- ; let bind = NonRec j y'
- ; x' <- simplExpr env' x
- ; arg_rep' <- simplType env' arg_rep
- ; arg_ty' <- simplType env' arg_ty
- ; let call' = mkApps (Var fun)
- [ mkTyArg arg_rep', mkTyArg arg_ty'
- , mkTyArg (getRuntimeRep ty'), mkTyArg ty'
- , x'
- , Var j
- ]
- ; --pprTrace "rebuild keepAlive" (ppr fun $$ ppr rev_args $$ ppr cont) $
- return (emptyFloats env `extendFloats` bind, call') }
-
----------- The runRW# rule. Do this after absorbing all arguments ------
--- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
--- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ])
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })
- | fun `hasKey` runRWKey
- , not (contIsStop cont) -- Don't fiddle around if the continuation is boring
- , [ TyArg {}, TyArg {} ] <- rev_args
- = do { s <- newId (fsLit "s") realWorldStatePrimTy
- ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
- , sc_env = env', sc_cont = cont }
- ; body' <- simplExprC env' arg cont'
- ; let arg' = Lam s body'
- ty' = contResultType cont
- rr' = getRuntimeRep ty'
- call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']
- ; return (emptyFloats env, call') }
+rebuildCall env arg_info cont
+ | Just do_it <- rebuildContPrimop env arg_info cont
+ = do_it
+---------- Simplify value applications --------------
rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
@@ -1986,6 +1938,72 @@ rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
= rebuild env (argInfoExpr fun rev_args) cont
+-- | A few primops take the form of:
+--
+-- @
+-- op :: ... -> a -> a
+-- @
+--
+-- and have semantics which permit us to "extend the reach" of their
+-- continuation. For instance, see Note [Simplifying runRW#].
+--
+-- Push strict contexts into keepAlive# continuation
+--
+-- That is,
+--
+-- K[keepAlive# @arg_rep @arg_ty @res_rep @res_ty x (\s -> rhs) s0] :: (out_ty :: TYPE out_rep)
+-- ~>
+-- keepAlive# @arg_rep @arg_ty @out_rep @out_ty x (\s -> K[rhs]) s0
+rebuildContPrimop :: SimplEnv -> ArgInfo -> SimplCont -> Maybe (SimplM (SimplFloats, OutExpr))
+rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
+ | fun `hasKey` keepAliveIdKey
+ , [ ValArg y
+ , ValArg x
+ , TyArg {} -- res_ty
+ , TyArg {} -- res_rep
+ , TyArg {as_arg_ty=arg_ty}
+ , TyArg {as_arg_ty=arg_rep}
+ ] <- rev_args
+ = Just $ do
+ { let ty' = contResultType cont
+ ; j <- newJoinId [] ty'
+ ; let env' = zapSubstEnv env
+ ; y' <- simplExprC env' y cont
+ ; let bind = NonRec j y'
+ ; x' <- simplExpr env' x
+ ; arg_rep' <- simplType env' arg_rep
+ ; arg_ty' <- simplType env' arg_ty
+ ; let call' = mkApps (Var fun)
+ [ mkTyArg arg_rep', mkTyArg arg_ty'
+ , mkTyArg (getRuntimeRep ty'), mkTyArg ty'
+ , x'
+ , Var j
+ ]
+ ; --pprTrace "rebuild keepAlive" (ppr fun $$ ppr rev_args $$ ppr cont) $
+ return (emptyFloats env `extendFloats` bind, call') }
+
+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
+-- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ])
+rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })
+ | fun `hasKey` runRWKey
+ , not (contIsStop cont) -- Don't fiddle around if the continuation is boring
+ , [ TyArg {}, TyArg {} ] <- rev_args
+ = Just $ do
+ { s <- newId (fsLit "s") realWorldStatePrimTy
+ ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
+ , sc_env = env', sc_cont = cont }
+ ; body' <- simplExprC env' arg cont'
+ ; let arg' = Lam s body'
+ ty' = contResultType cont
+ rr' = getRuntimeRep ty'
+ call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']
+ ; return (emptyFloats env, call') }
+
+rebuildContPrimop _ _ _ = Nothing
+
+
{- Note [Trying rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet
=====================================
libraries/base/Foreign/ForeignPtr/Imp.hs
=====================================
@@ -66,31 +66,6 @@ newForeignPtr finalizer p
addForeignPtrFinalizer finalizer fObj
return fObj
-withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
--- ^This is a way to look at the pointer living inside a
--- foreign object. This function takes a function which is
--- applied to that pointer. The resulting 'IO' action is then
--- executed. The foreign object is kept alive at least during
--- the whole action, even if it is not used directly
--- inside. Note that it is not safe to return the pointer from
--- the action and use it after the action completes. All uses
--- of the pointer should be inside the
--- 'withForeignPtr' bracket. The reason for
--- this unsafeness is the same as for
--- 'unsafeForeignPtrToPtr' below: the finalizer
--- may run earlier than expected, because the compiler can only
--- track usage of the 'ForeignPtr' object, not
--- a 'Ptr' object made from it.
---
--- This function is normally used for marshalling data to
--- or from the object pointed to by the
--- 'ForeignPtr', using the operations from the
--- 'Storable' class.
-withForeignPtr fo io
- = do r <- io (unsafeForeignPtrToPtr fo)
- touchForeignPtr fo
- return r
-
-- | This variant of 'newForeignPtr' adds a finalizer that expects an
-- environment in addition to the finalized pointer. The environment
-- that will be passed to the finalizer is fixed by the second argument to
=====================================
libraries/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -68,6 +68,7 @@ import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Base
+import GHC.Prim ( keepAlive# )
-- exported functions
-- ------------------
@@ -116,19 +117,6 @@ alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
alloca =
allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a))
--- Note [NOINLINE for touch#]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously
--- fragile in the presence of simplification (see #14346). In particular, the
--- simplifier may drop the continuation containing the touch# if it can prove
--- that the action passed to allocaBytes will not return. The hack introduced to
--- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the
--- simplifier can't see the divergence.
---
--- These can be removed once #14375 is fixed, which suggests that we instead do
--- away with touch# in favor of a primitive that will capture the scoping left
--- implicit in the case of touch#.
-
-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory of @n@ bytes.
-- The block of memory is sufficiently aligned for any of the basic
@@ -142,13 +130,9 @@ allocaBytes (I# size) action = IO $ \ s0 ->
case newPinnedByteArray# size s0 of { (# s1, mbarr# #) ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
- case action addr of { IO action' ->
- case action' s2 of { (# s3, r #) ->
- case touch# barr# s3 of { s4 ->
- (# s4, r #)
- }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytes #-}
+ case action addr of { IO action' ->
+ keepAlive# barr# (action' s2)
+ }}}
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
@@ -156,12 +140,8 @@ allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
case action addr of { IO action' ->
- case action' s2 of { (# s3, r #) ->
- case touch# barr# s3 of { s4 ->
- (# s4, r #)
- }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytesAligned #-}
+ keepAlive# barr# (action' s2)
+ }}}
-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the size needed to store values of type @b at . The returned pointer
=====================================
libraries/base/GHC/ForeignPtr.hs
=====================================
@@ -37,6 +37,7 @@ module GHC.ForeignPtr
mallocPlainForeignPtrAlignedBytes,
addForeignPtrFinalizer,
addForeignPtrFinalizerEnv,
+ withForeignPtr,
touchForeignPtr,
unsafeForeignPtrToPtr,
castForeignPtr,
@@ -54,6 +55,7 @@ import GHC.Base
import GHC.IORef
import GHC.STRef ( STRef(..) )
import GHC.Ptr ( Ptr(..), FunPtr(..) )
+import GHC.Prim ( keepAlive# )
import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted )
@@ -388,6 +390,31 @@ newForeignPtr_ (Ptr obj) = do
r <- newIORef NoFinalizers
return (ForeignPtr obj (PlainForeignPtr r))
+withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+-- ^This is a way to look at the pointer living inside a
+-- foreign object. This function takes a function which is
+-- applied to that pointer. The resulting 'IO' action is then
+-- executed. The foreign object is kept alive at least during
+-- the whole action, even if it is not used directly
+-- inside. Note that it is not safe to return the pointer from
+-- the action and use it after the action completes. All uses
+-- of the pointer should be inside the
+-- 'withForeignPtr' bracket. The reason for
+-- this unsafeness is the same as for
+-- 'unsafeForeignPtrToPtr' below: the finalizer
+-- may run earlier than expected, because the compiler can only
+-- track usage of the 'ForeignPtr' object, not
+-- a 'Ptr' object made from it.
+--
+-- This function is normally used for marshalling data to
+-- or from the object pointed to by the
+-- 'ForeignPtr', using the operations from the
+-- 'Storable' class.
+withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
+ case f (unsafeForeignPtrToPtr fo) of
+ IO action# -> keepAlive# r (action# s)
+
+
touchForeignPtr :: ForeignPtr a -> IO ()
-- ^This function ensures that the foreign object in
-- question is alive at the given place in the sequence of IO
=====================================
libraries/ghc-compact/GHC/Compact/Serialized.hs
=====================================
@@ -74,12 +74,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
rest <- go next
return $ item : rest
--- We MUST mark withSerializedCompact as NOINLINE
--- Otherwise the compiler will eliminate the call to touch#
--- causing the Compact# to be potentially GCed too eagerly,
--- before func had a chance to copy everything into its own
--- buffers/sockets/whatever
-
-- | Serialize the 'Compact', and call the provided function with
-- with the 'Compact' serialized representation. It is not safe
-- to return the pointer from the action and use it after
@@ -89,7 +83,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
-- unsound to use 'unsafeInterleaveIO' to lazily construct
-- a lazy bytestring from the 'Ptr'.
--
-{-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: Compact a ->
(SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
@@ -97,9 +90,7 @@ withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
(# s', rootAddr #) -> (# s', Ptr rootAddr #) )
blockList <- mkBlockList buffer
let serialized = SerializedCompact blockList rootPtr
- r <- func serialized
- IO (\s -> case touch# buffer s of
- s' -> (# s', r #) )
+ IO (\s1 -> case func serialized of IO action' -> keepAlive# buffer (action' s1))
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51f194f7d0b9af680514f39c8f5878164eecb1e5...0355527190c61abea8ff4b7bb2c81510ae23b7d9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51f194f7d0b9af680514f39c8f5878164eecb1e5...0355527190c61abea8ff4b7bb2c81510ae23b7d9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200424/ca943063/attachment-0001.html>
More information about the ghc-commits
mailing list