[Git][ghc/ghc][wip/keepAlive-the-return-of-the-primop] 13 commits: GHC.Utils.Binary: Eliminate allocating withForeignPtr uses
Ben Gamari
gitlab at gitlab.haskell.org
Sun Nov 29 17:04:02 UTC 2020
Ben Gamari pushed to branch wip/keepAlive-the-return-of-the-primop at Glasgow Haskell Compiler / GHC
Commits:
a20e6c8c by Ben Gamari at 2020-11-27T14:33:51-05:00
GHC.Utils.Binary: Eliminate allocating withForeignPtr uses
- - - - -
6ca6b8e7 by Ben Gamari at 2020-11-27T14:33:51-05:00
base: Eliminate allocating withForeignPtrs from GHC.Event.Array
- - - - -
7d79edbd by Ben Gamari at 2020-11-28T13:12:29-05:00
base: Use unsafeWithForeignPtr in GHC.IO.Buffer
- - - - -
fa6edd4d by Ben Gamari at 2020-11-28T13:12:29-05:00
GHC.Event.Array: Use unsafeWithForeignPtr
- - - - -
f40b662b by Ben Gamari at 2020-11-28T13:12:43-05:00
Bump bytestring submodule
Teach it to use unsafeWithForeignPtr where appropriate.
- - - - -
6aad2ebe by Ben Gamari at 2020-11-29T12:03:51-05:00
genprimopcode: Add a second levity-polymorphic tyvar
This will be needed shortly.
- - - - -
effa1308 by GHC GitLab CI at 2020-11-29T12:03:51-05:00
Introduce keepAlive primop
- - - - -
4b8b9241 by Ben Gamari at 2020-11-29T12:03:51-05:00
base: Use keepAlive# in withForeignPtr
- - - - -
d11752ef by Ben Gamari at 2020-11-29T12:03:51-05:00
Implement withByteArrayContents in terms of keepAlive#
- - - - -
94f3ac80 by Ben Gamari at 2020-11-29T12:03:51-05:00
base: Implement GHC.ForeignPtr.Ops in terms of keepAlive#
- - - - -
8f7df80b by Ben Gamari at 2020-11-29T12:03:51-05:00
base: Use keepAlive# in Foreign.Marshal.Alloc
- - - - -
7c7506bf by Ben Gamari at 2020-11-29T12:03:51-05:00
ghc-compact: Use keepAlive# in GHC.Compact.Serialized
- - - - -
b7910e3f by Ben Gamari at 2020-11-29T12:03:51-05:00
testsuite: Accept
- - - - -
18 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/ByteArray.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Utils/Binary.hs
- libraries/base/Foreign/Marshal/Alloc.hs
- libraries/base/GHC/Event/Array.hs
- libraries/base/GHC/ForeignPtr.hs
- libraries/base/GHC/ForeignPtr/Ops.hs
- libraries/base/GHC/IO/Buffer.hs
- libraries/bytestring
- libraries/ghc-compact/GHC/Compact/Serialized.hs
- testsuite/tests/ghci/should_fail/T15055.stderr
- testsuite/tests/package/package06e.stderr
- testsuite/tests/package/package07e.stderr
- testsuite/tests/package/package08e.stderr
- utils/genprimopcode/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2963,6 +2963,20 @@ primop NumSparks "numSparks#" GenPrimOp
has_side_effects = True
out_of_line = True
+
+------------------------------------------------------------------------
+section "Controlling object lifetime"
+ {Ensuring that objects don't die a premature death.}
+------------------------------------------------------------------------
+
+-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
+primop KeepAliveOp "keepAlive#" GenPrimOp
+ o -> State# RealWorld -> (State# RealWorld -> p) -> p
+ { TODO. }
+ with
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }
+
+
------------------------------------------------------------------------
section "Tag to enum stuff"
{Convert back and forth between values of enumerated types
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1642,6 +1642,8 @@ app_ok primop_ok fun args
-> False -- for the special cases for SeqOp and DataToTagOp
| DataToTagOp <- op
-> False
+ | KeepAliveOp <- op
+ -> False
| otherwise
-> primop_ok op -- Check the primop itself
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -32,7 +32,10 @@ import GHC.Tc.Utils.Env
import GHC.Unit
import GHC.Builtin.Names
+import GHC.Builtin.PrimOps
import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
+import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
import GHC.Core.Utils
import GHC.Core.Opt.Arity
@@ -47,6 +50,7 @@ import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
+
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
@@ -63,7 +67,6 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
@@ -784,6 +787,38 @@ cpeApp top_env expr
-- rather than the far superior "f x y". Test case is par01.
= let (terminal, args', depth') = collect_args arg
in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+
+ cpe_app env
+ (Var f)
+ args
+ n
+ | Just KeepAliveOp <- isPrimOpId_maybe f
+ , CpeApp (Type arg_rep)
+ : CpeApp (Type arg_ty)
+ : CpeApp (Type _result_rep)
+ : CpeApp (Type result_ty)
+ : CpeApp arg
+ : CpeApp s0
+ : CpeApp k
+ : rest <- pprTrace "cpe_app keepAlive#" (ppr args) args
+ = do { pprTraceM "cpe_app(keepAlive#)" (ppr n)
+ ; y <- newVar result_ty
+ ; s2 <- newVar realWorldStatePrimTy
+ ; -- beta reduce if possible
+ ; (floats, k') <- case k of
+ Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)
+ _ -> cpe_app env k (CpeApp s0 : rest) (n-1)
+ ; let touchId = mkPrimOpId TouchOp
+ expr = Case k' y result_ty [(DEFAULT, [], rhs)]
+ rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]
+ in Case scrut s2 result_ty [(DEFAULT, [], Var y)]
+ ; pprTraceM "cpe_app(keepAlive)" (ppr expr)
+ ; (floats', expr') <- cpeBody env expr
+ ; return (floats `appendFloats` floats', expr')
+ }
+ | Just KeepAliveOp <- isPrimOpId_maybe f
+ = panic "invalid keepAlive# application"
+
cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) n
| f `hasKey` runRWKey
-- N.B. While it may appear that n == 1 in the case of runRW#
=====================================
compiler/GHC/Data/ByteArray.hs
=====================================
@@ -77,10 +77,15 @@ unsafeMutableByteArrayContents :: MutableByteArray -> Ptr a
unsafeMutableByteArrayContents = unsafeByteArrayContents . unsafeCoerce
withByteArrayContents :: ByteArray -> (Ptr a -> IO b) -> IO b
+#if MIN_VERSION_base(4,15,0)
+withByteArrayContents (ByteArray ba) f =
+ IO $ \s -> keepAlive# ba s (unIO (f (Ptr (byteArrayContents# ba))))
+#else
withByteArrayContents (ByteArray ba) f = do
r <- f $ Ptr (byteArrayContents# ba)
IO $ \s -> case touch# ba s of s' -> (# s', () #)
return r
+#endif
newMutableByteArray :: Int -> IO MutableByteArray
newMutableByteArray (I# size) = IO $ \s ->
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1541,6 +1541,8 @@ emitPrimOp dflags primop = case primop of
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"
+
where
profile = targetProfile dflags
platform = profilePlatform profile
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
@@ -84,6 +85,7 @@ import Data.Array
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
+import GHC.ForeignPtr
import Data.IORef
import Data.Char ( ord, chr )
import Data.Time
@@ -96,7 +98,10 @@ import GHC.Real ( Ratio(..) )
type BinArray = ForeignPtr Word8
-
+#if !MIN_VERSION_base(4,15,0)
+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+unsafeWithForeignPtr = withForeignPtr
+#endif
---------------------------------------------------------------
-- BinData
@@ -111,14 +116,14 @@ instance Binary BinData where
put_ bh (BinData sz dat) = do
put_ bh sz
putPrim bh sz $ \dest ->
- withForeignPtr dat $ \orig ->
+ unsafeWithForeignPtr dat $ \orig ->
copyBytes dest orig sz
--
get bh = do
sz <- get bh
dat <- mallocForeignPtrBytes sz
getPrim bh sz $ \orig ->
- withForeignPtr dat $ \dest ->
+ unsafeWithForeignPtr dat $ \dest ->
copyBytes dest orig sz
return (BinData sz dat)
@@ -226,7 +231,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
- withForeignPtr arr $ \p -> hPutBuf h p ix
+ unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix
hClose h
readBinMem :: FilePath -> IO BinHandle
@@ -236,7 +241,7 @@ readBinMem filename = do
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
arr <- mallocForeignPtrBytes filesize
- count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
+ count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
hClose h
@@ -280,7 +285,7 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
when (ix + size > sz) $
expandBin h (ix + size)
arr <- readIORef arr_r
- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+ unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)
writeFastMutInt ix_r (ix + size)
-- -- | Similar to putPrim but advances the index by the actual number of
@@ -302,7 +307,10 @@ getPrim (BinMem _ ix_r sz_r arr_r) size f = do
when (ix + size > sz) $
ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
arr <- readIORef arr_r
- w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+ w <- f (unsafeForeignPtrToPtr arr `plusPtr` ix)
+ touchForeignPtr arr
+ -- This is safe WRT #17760 as we we guarantee that the above line doesn't
+ -- diverge
writeFastMutInt ix_r (ix + size)
return w
=====================================
libraries/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -116,19 +116,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
@@ -143,12 +130,8 @@ allocaBytes (I# size) 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 allocaBytes #-}
+ keepAlive# barr# s2 action'
+ }}}
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
@@ -156,12 +139,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# s2 action'
+ }}}
-- |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/Event/Array.hs
=====================================
@@ -33,7 +33,7 @@ import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Foreign.Storable (Storable(..))
import GHC.Base hiding (empty)
-import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_)
+import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_, unsafeWithForeignPtr)
import GHC.Num (Num(..))
import GHC.Real (fromIntegral)
import GHC.Show (show)
@@ -78,9 +78,9 @@ reallocArray p newSize oldSize = reallocHack undefined p
reallocHack dummy src = do
let size = sizeOf dummy
dst <- mallocPlainForeignPtrBytes (newSize * size)
- withForeignPtr src $ \s ->
+ unsafeWithForeignPtr src $ \s ->
when (s /= nullPtr && oldSize > 0) .
- withForeignPtr dst $ \d -> do
+ unsafeWithForeignPtr dst $ \d -> do
_ <- memcpy d s (fromIntegral (oldSize * size))
return ()
return dst
@@ -99,8 +99,8 @@ duplicate a = dupHack undefined a
dupHack dummy (Array ref) = do
AC es len cap <- readIORef ref
ary <- allocArray cap
- withForeignPtr ary $ \dest ->
- withForeignPtr es $ \src -> do
+ unsafeWithForeignPtr ary $ \dest ->
+ unsafeWithForeignPtr es $ \src -> do
_ <- memcpy dest src (fromIntegral (len * sizeOf dummy))
return ()
Array `fmap` newIORef (AC ary len cap)
@@ -119,8 +119,8 @@ unsafeRead :: Storable a => Array a -> Int -> IO a
unsafeRead (Array ref) ix = do
AC es _ cap <- readIORef ref
CHECK_BOUNDS("unsafeRead",cap,ix)
- withForeignPtr es $ \p ->
- peekElemOff p ix
+ unsafeWithForeignPtr es $ \ptr -> peekElemOff ptr ix
+ -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge
unsafeWrite :: Storable a => Array a -> Int -> a -> IO ()
unsafeWrite (Array ref) ix a = do
@@ -130,13 +130,15 @@ unsafeWrite (Array ref) ix a = do
unsafeWrite' :: Storable a => AC a -> Int -> a -> IO ()
unsafeWrite' (AC es _ cap) ix a =
CHECK_BOUNDS("unsafeWrite'",cap,ix)
- withForeignPtr es $ \p ->
- pokeElemOff p ix a
+ unsafeWithForeignPtr es $ \ptr -> pokeElemOff ptr ix a
+ -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge
+-- | Precondition: continuation must not diverge due to use of
+-- 'unsafeWithForeignPtr'.
unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int
unsafeLoad (Array ref) load = do
AC es _ cap <- readIORef ref
- len' <- withForeignPtr es $ \p -> load p cap
+ len' <- unsafeWithForeignPtr es $ \p -> load p cap
writeIORef ref (AC es len' cap)
return len'
@@ -146,7 +148,7 @@ unsafeCopyFromBuffer :: Storable a => Array a -> Ptr a -> Int -> IO ()
unsafeCopyFromBuffer (Array ref) sptr n =
readIORef ref >>= \(AC es _ cap) ->
CHECK_BOUNDS("unsafeCopyFromBuffer", cap, n)
- withForeignPtr es $ \pdest -> do
+ unsafeWithForeignPtr es $ \pdest -> do
let size = sizeOfPtr sptr undefined
_ <- memcpy pdest sptr (fromIntegral $ n * size)
writeIORef ref (AC es n cap)
@@ -198,7 +200,7 @@ forM_ ary g = forHack ary g undefined
AC es len _ <- readIORef ref
let size = sizeOf dummy
offset = len * size
- withForeignPtr es $ \p -> do
+ unsafeWithForeignPtr es $ \p -> do
let go n | n >= offset = return ()
| otherwise = do
f =<< peek (p `plusPtr` n)
@@ -269,8 +271,8 @@ copy' d dstart s sstart maxCount = copyHack d s undefined
then return dac
else do
AC dst dlen dcap <- ensureCapacity' dac (dstart + count)
- withForeignPtr dst $ \dptr ->
- withForeignPtr src $ \sptr -> do
+ unsafeWithForeignPtr dst $ \dptr ->
+ unsafeWithForeignPtr src $ \sptr -> do
_ <- memcpy (dptr `plusPtr` (dstart * size))
(sptr `plusPtr` (sstart * size))
(fromIntegral (count * size))
@@ -286,7 +288,7 @@ removeAt a i = removeHack a undefined
let size = sizeOf dummy
newLen = oldLen - 1
when (newLen > 0 && i < newLen) .
- withForeignPtr fp $ \ptr -> do
+ unsafeWithForeignPtr fp $ \ptr -> do
_ <- memmove (ptr `plusPtr` (size * i))
(ptr `plusPtr` (size * (i+1)))
(fromIntegral (size * (newLen-i)))
=====================================
libraries/base/GHC/ForeignPtr.hs
=====================================
@@ -526,7 +526,9 @@ withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
-- or from the object pointed to by the
-- 'ForeignPtr', using the operations from the
-- 'Storable' class.
-withForeignPtr = unsafeWithForeignPtr
+withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
+ case f (unsafeForeignPtrToPtr fo) of
+ IO action# -> keepAlive# r s action#
-- | This is similar to 'withForeignPtr' but comes with an important caveat:
-- the user must guarantee that the continuation does not diverge (e.g. loop or
=====================================
libraries/base/GHC/ForeignPtr/Ops.hs
=====================================
@@ -51,121 +51,114 @@ import GHC.Word
import GHC.Int
import GHC.Base
import GHC.ForeignPtr
-import GHC.Ptr
-
-withFP :: ForeignPtr a
- -> (Addr# -> State# RealWorld -> (# State# RealWorld, b #))
- -> IO b
-withFP fp f =
- withForeignPtr fp (\(Ptr addr) -> IO (f addr))
peekWord8ForeignPtr :: ForeignPtr ty -> Int -> IO Word8
-peekWord8ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readWord8OffAddr# addr d s0 of
+peekWord8ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readWord8OffAddr# addr d) of
(# s1, r #) -> (# s1, W8# r #)
peekWord16ForeignPtr :: ForeignPtr ty -> Int -> IO Word16
-peekWord16ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readWord16OffAddr# addr d s0 of
+peekWord16ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readWord16OffAddr# addr d) of
(# s1, r #) -> (# s1, W16# r #)
peekWord32ForeignPtr :: ForeignPtr ty -> Int -> IO Word32
-peekWord32ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readWord32OffAddr# addr d s0 of
+peekWord32ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readWord32OffAddr# addr d) of
(# s1, r #) -> (# s1, W32# r #)
peekWord64ForeignPtr :: ForeignPtr ty -> Int -> IO Word64
-peekWord64ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readWord64OffAddr# addr d s0 of
+peekWord64ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readWord64OffAddr# addr d) of
(# s1, r #) -> (# s1, W64# r #)
peekWordForeignPtr :: ForeignPtr ty -> Int -> IO Word
-peekWordForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readWord64OffAddr# addr d s0 of
+peekWordForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readWord64OffAddr# addr d) of
(# s1, r #) -> (# s1, W# r #)
peekInt8ForeignPtr :: ForeignPtr ty -> Int -> IO Int8
-peekInt8ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readInt64OffAddr# addr d s0 of
+peekInt8ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readInt64OffAddr# addr d) of
(# s1, r #) -> (# s1, I8# r #)
peekInt16ForeignPtr :: ForeignPtr ty -> Int -> IO Int16
-peekInt16ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readInt64OffAddr# addr d s0 of
+peekInt16ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readInt64OffAddr# addr d) of
(# s1, r #) -> (# s1, I16# r #)
peekInt32ForeignPtr :: ForeignPtr ty -> Int -> IO Int32
-peekInt32ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readInt64OffAddr# addr d s0 of
+peekInt32ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readInt64OffAddr# addr d) of
(# s1, r #) -> (# s1, I32# r #)
peekInt64ForeignPtr :: ForeignPtr ty -> Int -> IO Int64
-peekInt64ForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readInt64OffAddr# addr d s0 of
+peekInt64ForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readInt64OffAddr# addr d) of
(# s1, r #) -> (# s1, I64# r #)
peekIntForeignPtr :: ForeignPtr ty -> Int -> IO Int
-peekIntForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readInt64OffAddr# addr d s0 of
+peekIntForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readInt64OffAddr# addr d) of
(# s1, r #) -> (# s1, I# r #)
peekCharForeignPtr :: ForeignPtr ty -> Int -> IO Char
-peekCharForeignPtr fp (I# d) = withFP fp $ \addr s0 ->
- case readCharOffAddr# addr d s0 of
+peekCharForeignPtr (ForeignPtr addr c) (I# d) = IO $ \s0 ->
+ case keepAlive# c s0 (readCharOffAddr# addr d) of
(# s1, r #) -> (# s1, C# r #)
pokeWord8ForeignPtr :: ForeignPtr ty -> Int -> Word8 -> IO ()
-pokeWord8ForeignPtr fp (I# d) (W8# n) = withFP fp $ \addr s0 ->
- case writeWord8OffAddr# addr d n s0 of
+pokeWord8ForeignPtr (ForeignPtr addr c) (I# d) (W8# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeWord8OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeWord16ForeignPtr :: ForeignPtr ty -> Int -> Word16 -> IO ()
-pokeWord16ForeignPtr fp (I# d) (W16# n) = withFP fp $ \addr s0 ->
- case writeWord16OffAddr# addr d n s0 of
+pokeWord16ForeignPtr (ForeignPtr addr c) (I# d) (W16# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeWord16OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeWord32ForeignPtr :: ForeignPtr ty -> Int -> Word32 -> IO ()
-pokeWord32ForeignPtr fp (I# d) (W32# n) = withFP fp $ \addr s0 ->
- case writeWord32OffAddr# addr d n s0 of
+pokeWord32ForeignPtr (ForeignPtr addr c) (I# d) (W32# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeWord32OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeWord64ForeignPtr :: ForeignPtr ty -> Int -> Word64 -> IO ()
-pokeWord64ForeignPtr fp (I# d) (W64# n) = withFP fp $ \addr s0 ->
- case writeWord64OffAddr# addr d n s0 of
+pokeWord64ForeignPtr (ForeignPtr addr c) (I# d) (W64# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeWord64OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeWordForeignPtr :: ForeignPtr ty -> Int -> Word -> IO ()
-pokeWordForeignPtr fp (I# d) (W# n) = withFP fp $ \addr s0 ->
- case writeWord64OffAddr# addr d n s0 of
+pokeWordForeignPtr (ForeignPtr addr c) (I# d) (W# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeWord64OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeInt8ForeignPtr :: ForeignPtr ty -> Int -> Int8 -> IO ()
-pokeInt8ForeignPtr fp (I# d) (I8# n) = withFP fp $ \addr s0 ->
- case writeInt8OffAddr# addr d n s0 of
+pokeInt8ForeignPtr (ForeignPtr addr c) (I# d) (I8# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeInt8OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeInt16ForeignPtr :: ForeignPtr ty -> Int -> Int16 -> IO ()
-pokeInt16ForeignPtr fp (I# d) (I16# n) = withFP fp $ \addr s0 ->
- case writeInt16OffAddr# addr d n s0 of
+pokeInt16ForeignPtr (ForeignPtr addr c) (I# d) (I16# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeInt16OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeInt32ForeignPtr :: ForeignPtr ty -> Int -> Int32 -> IO ()
-pokeInt32ForeignPtr fp (I# d) (I32# n) = withFP fp $ \addr s0 ->
- case writeInt32OffAddr# addr d n s0 of
+pokeInt32ForeignPtr (ForeignPtr addr c) (I# d) (I32# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeInt32OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeInt64ForeignPtr :: ForeignPtr ty -> Int -> Int64 -> IO ()
-pokeInt64ForeignPtr fp (I# d) (I64# n) = withFP fp $ \addr s0 ->
- case writeInt64OffAddr# addr d n s0 of
+pokeInt64ForeignPtr (ForeignPtr addr c) (I# d) (I64# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeInt64OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeIntForeignPtr :: ForeignPtr ty -> Int -> Int -> IO ()
-pokeIntForeignPtr fp (I# d) (I# n) = withFP fp $ \addr s0 ->
- case writeInt64OffAddr# addr d n s0 of
+pokeIntForeignPtr (ForeignPtr addr c) (I# d) (I# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeInt64OffAddr# addr d n) of
s1 -> (# s1, () #)
pokeCharForeignPtr :: ForeignPtr ty -> Int -> Char -> IO ()
-pokeCharForeignPtr fp (I# d) (C# n) = withFP fp $ \addr s0 ->
- case writeCharOffAddr# addr d n s0 of
+pokeCharForeignPtr (ForeignPtr addr c) (I# d) (C# n) = IO $ \s0 ->
+ case keepAlive# c s0 (writeCharOffAddr# addr d n) of
s1 -> (# s1, () #)
=====================================
libraries/base/GHC/IO/Buffer.hs
=====================================
@@ -73,6 +73,7 @@ import GHC.Show
import GHC.Real
import GHC.List
import GHC.ForeignPtr.Ops
+import GHC.ForeignPtr (unsafeWithForeignPtr)
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Storable
@@ -118,17 +119,17 @@ type CharBufElem = Char
type RawCharBuffer = RawBuffer CharBufElem
peekCharBuf :: RawCharBuffer -> Int -> IO Char
-peekCharBuf arr ix = withForeignPtr arr $ \p -> do
+peekCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> do
(c,_) <- readCharBufPtr p ix
return c
{-# INLINE readCharBuf #-}
readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
-readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
+readCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> readCharBufPtr p ix
{-# INLINE writeCharBuf #-}
writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
-writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
+writeCharBuf arr ix c = unsafeWithForeignPtr arr $ \p -> writeCharBufPtr p ix c
{-# INLINE readCharBufPtr #-}
readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit e043aacfc4202a59ccae8b8c8cf0e1ad83a3f209
+Subproject commit 8d5d8bd463f10244e3754dd03e4bf020a0ea03e3
=====================================
libraries/ghc-compact/GHC/Compact/Serialized.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Compact.Serialized(
import GHC.Prim
import GHC.Types
import GHC.Word (Word8)
+import GHC.IO (unIO)
import GHC.Ptr (Ptr(..), plusPtr)
@@ -74,12 +75,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 +84,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 +91,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 $ \s -> keepAlive# buffer s (unIO $ func serialized)
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
=====================================
testsuite/tests/ghci/should_fail/T15055.stderr
=====================================
@@ -1,6 +1,9 @@
<no location info>: error:
Could not load module ‘GHC’
- It is a member of the hidden package ‘ghc-8.5’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
=====================================
testsuite/tests/package/package06e.stderr
=====================================
@@ -1,14 +1,20 @@
package06e.hs:2:1: error:
Could not load module ‘GHC.Hs.Type’
- It is a member of the hidden package ‘ghc-8.7’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package06e.hs:3:1: error:
Could not load module ‘GHC.Types.Unique.FM’
- It is a member of the hidden package ‘ghc-8.7’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
=====================================
testsuite/tests/package/package07e.stderr
=====================================
@@ -2,27 +2,37 @@
package07e.hs:2:1: error:
Could not find module ‘GHC.Hs.MyTypes’
Perhaps you meant
- GHC.Hs.Type (needs flag -package-id ghc-8.11.0.20200401)
- GHC.Tc.Types (needs flag -package-id ghc-8.11.0.20200401)
+ GHC.Hs.Type (needs flag -package-id ghc-9.1.0.20201120)
+ GHC.Hs.Type (needs flag -package-id ghc-9.1.0.20201022)
+ GHC.Tc.Types (needs flag -package-id ghc-9.1.0.20201120)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:3:1: error:
Could not load module ‘GHC.Hs.Type’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:4:1: error:
Could not load module ‘GHC.Hs.Utils’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:5:1: error:
Could not load module ‘GHC.Types.Unique.FM’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
=====================================
testsuite/tests/package/package08e.stderr
=====================================
@@ -2,27 +2,37 @@
package08e.hs:2:1: error:
Could not find module ‘GHC.Hs.MyTypes’
Perhaps you meant
- GHC.Hs.Type (needs flag -package-id ghc-8.11.0.20200401)
- GHC.Tc.Types (needs flag -package-id ghc-8.11.0.20200401)
+ GHC.Hs.Type (needs flag -package-id ghc-9.1.0.20201120)
+ GHC.Hs.Type (needs flag -package-id ghc-9.1.0.20201022)
+ GHC.Tc.Types (needs flag -package-id ghc-9.1.0.20201120)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:3:1: error:
Could not load module ‘GHC.Hs.Type’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:4:1: error:
Could not load module ‘GHC.Hs.Utils’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:5:1: error:
Could not load module ‘GHC.Types.Unique.FM’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.1.0.20201022’.
+ You can run ‘:set -package ghc’ to expose it.
+ (Note: this unloads all the modules in the current scope.)
+ It is a member of the hidden package ‘ghc-9.1.0.20201120’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -503,6 +503,7 @@ gen_latex_doc (Info defaults entries)
tvars = tvars_of typ
tbinds [] = ". "
tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
+ tbinds ("p":tbs) = "(p::?) " ++ (tbinds tbs)
tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
@@ -852,6 +853,7 @@ ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
+ppTyVar "p" = "runtimeRep2TyVar, openBetaTyVar"
ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
@@ -885,6 +887,7 @@ ppType (TyVar "b") = "betaTy"
ppType (TyVar "c") = "gammaTy"
ppType (TyVar "s") = "deltaTy"
ppType (TyVar "o") = "openAlphaTy"
+ppType (TyVar "p") = "openBetaTy"
ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c80bd7791960c8cc28021aa89726996d524bbb9f...b7910e3fa09c1e9c0ce42bb600dd007bd1e79297
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c80bd7791960c8cc28021aa89726996d524bbb9f...b7910e3fa09c1e9c0ce42bb600dd007bd1e79297
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/20201129/f6c979a6/attachment-0001.html>
More information about the ghc-commits
mailing list