diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 14cfc22cc1cb494a0b36f8afb51faf85bc628d67..f7275e4698a6a77788f2e8eeae4db775d2c3729e 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -349,6 +349,7 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + cstringLengthName, -- Overloaded lists isListClassName, @@ -1014,10 +1015,11 @@ modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey -- Base strings Strings unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName :: Name + unpackCStringUtf8Name, eqStringName, cstringLengthName :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey -- The 'inline' function @@ -2097,7 +2099,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, unpackCStringUtf8IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, - absentSumFieldErrorIdKey :: Unique + absentSumFieldErrorIdKey, cstringLengthIdKey :: Unique wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] absentErrorIdKey = mkPreludeMiscIdUnique 1 @@ -2124,6 +2126,7 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21 typeErrorIdKey = mkPreludeMiscIdUnique 22 divIntIdKey = mkPreludeMiscIdUnique 23 modIntIdKey = mkPreludeMiscIdUnique 24 +cstringLengthIdKey = mkPreludeMiscIdUnique 25 concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 7c18f27003392394088d4315a03be445469d71ec..65c9ed38964334f88ff68c1d4022270e281cbb78 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -66,6 +66,7 @@ import qualified Data.ByteString as BS import Data.Int import Data.Ratio import Data.Word +import Data.Maybe (fromMaybe) {- Note [Constant folding] @@ -1257,6 +1258,8 @@ builtinRules ru_nargs = 4, ru_try = match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, + ru_nargs = 1, ru_try = match_cstring_length }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, @@ -1477,6 +1480,30 @@ match_eq_string _ id_unf _ match_eq_string _ _ _ _ = Nothing +----------------------------------------------------------------------- +-- Illustration of this rule: +-- +-- cstringLength# "foobar"# --> 6 +-- cstringLength# "fizz\NULzz"# --> 4 +-- +-- Nota bene: Addr# literals are suffixed by a NUL byte when they are +-- compiled to read-only data sections. That's why cstringLength# is +-- well defined on Addr# literals that do not explicitly have an embedded +-- NUL byte. +-- +-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly +-- helpful when using OverloadedStrings to create a ByteString since the +-- function computing the length of such ByteStrings can often be constant +-- folded. +match_cstring_length :: RuleFun +match_cstring_length env id_unf _ [lit1] + | Just (LitString str) <- exprIsLiteral_maybe id_unf lit1 + -- If elemIndex returns Just, it has the index of the first embedded NUL + -- in the string. If no NUL bytes are present (the common case) then use + -- full length of the byte string. + = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str) + in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len))) +match_cstring_length _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs index 82f38601f59850593cb88766f16ef7f209de94f7..a8ffaff61987b97eb7020c38ebde7b5ab932017b 100644 --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -128,8 +128,9 @@ import Foreign import GHC.Conc.Sync (sharedCAF) #endif -import GHC.Base ( unpackCString#, unpackNBytes# ) - +#if __GLASGOW_HASKELL__ < 811 +import GHC.Base (unpackCString#,unpackNBytes#) +#endif -- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' bytesFS :: FastString -> ByteString diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 75e5c1d315f4966a75b7ed056d8b338dc59e538d..78155289d06bcf4dff41f6b5ae5a2600d7ff23f5 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -53,7 +53,7 @@ data HsLit x -- ^ Unboxed character | HsString (XHsString x) {- SourceText -} FastString -- ^ String - | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString + | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString -- ^ Packed bytes | HsInt (XHsInt x) IntegralLit -- ^ Genuinely an Int; arises from diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 453106eaeca36e5326f4fe97f2b94517a545ff4f..359f8d06069cc47ef5bd8cfe9ce395cec8752073 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -6,6 +6,7 @@ This module converts Template Haskell syntax into Hs syntax -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -1232,8 +1233,7 @@ cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' ; return $ HsString (quotedSourceText s) s' } -cvtLit (StringPrimL s) = do { let { s' = BS.pack s } - ; force s' +cvtLit (StringPrimL s) = do { let { !s' = BS.pack s } ; return $ HsStringPrim NoSourceText s' } cvtLit (BytesPrimL (Bytes fptr off sz)) = do let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index c31f6349db2efbb622deda648b1bc8bb1f711815..c57cc2bb978499d7f58f2d83f3f08a793f7b80fe 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -114,7 +114,7 @@ data Literal -- See Note [Types of LitNumbers] below for the -- Type field. - | LitString ByteString -- ^ A string-literal: stored and emitted + | LitString !ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it -- at runtime. Also emitted with a @\'\\0\'@ -- terminator. Create with 'mkLitString' diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst index b98b1f283b34c7bb732c518f6612ddb87f467dcb..dc666f8064add4d6c7cb2cb83d916c93e4e419fa 100644 --- a/docs/users_guide/8.12.1-notes.rst +++ b/docs/users_guide/8.12.1-notes.rst @@ -144,6 +144,9 @@ Arrow notation ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ +- Add a known-key ``cstringLength#`` to ``GHC.CString`` that is eligible + for constant folding by a built-in rule. + ``ghc`` library ~~~~~~~~~~~~~~~ @@ -181,6 +184,15 @@ Arrow notation ``base`` library ~~~~~~~~~~~~~~~~ +- ``ForeignPtrContents`` has a new nullary data constructor ``FinalPtr``. + ``FinalPtr`` is intended for turning a primitive string literal into a + ``ForeignPtr``. Unlike ``PlainForeignPtr``, ``FinalPtr`` does not have + a finalizer. Replacing ``PlainForeignPtr`` that has ``NoFinalizers`` with + ``FinalPtr`` reduces allocations, reduces the size of compiled binaries, + and unlocks important Core-to-Core optimizations. ``FinalPtr`` will be used + in an upcoming ``bytestring`` release to improve the performance of + ``ByteString`` literals created with ``OverloadedStrings``. + Build system ~~~~~~~~~~~~ diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 894ffad5094a1e188da89be565693cd652dc1062..8f878b813b0fa658663f4999fccce31ed8a4a036 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -54,6 +54,14 @@ module GHC.Exts -- * Overloaded string literals IsString(..), + -- * CString + unpackCString#, + unpackAppendCString#, + unpackFoldrCString#, + unpackCStringUtf8#, + unpackNBytes#, + cstringLength#, + -- * Debugging breakpoint, breakpointCond, diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 92aef540d1fde92c2b5ed4db3e6c2c597f00a0ec..9ba6a2b0174e2e5c97c94b412f582ecd3b8267a7 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -23,11 +23,13 @@ module GHC.ForeignPtr ( + -- * Types ForeignPtr(..), ForeignPtrContents(..), Finalizers(..), FinalizerPtr, FinalizerEnvPtr, + -- * Create newForeignPtr_, mallocForeignPtr, mallocPlainForeignPtr, @@ -35,15 +37,20 @@ module GHC.ForeignPtr mallocPlainForeignPtrBytes, mallocForeignPtrAlignedBytes, mallocPlainForeignPtrAlignedBytes, + newConcForeignPtr, + -- * Add Finalizers addForeignPtrFinalizer, addForeignPtrFinalizerEnv, - touchForeignPtr, + addForeignPtrConcFinalizer, + -- * Conversion unsafeForeignPtrToPtr, castForeignPtr, plusForeignPtr, - newConcForeignPtr, - addForeignPtrConcFinalizer, + -- * Finalization + touchForeignPtr, finalizeForeignPtr + -- * Commentary + -- $commentary ) where import Foreign.Storable @@ -86,15 +93,121 @@ data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents -- object, because that ensures that whatever the finalizer is -- attached to is kept alive. +-- | Functions called when a 'ForeignPtr' is finalized. Note that +-- C finalizers and Haskell finalizers cannot be mixed. data Finalizers = NoFinalizers + -- ^ No finalizer. If there is no intent to add a finalizer at + -- any point in the future, consider 'FinalPtr' or 'PlainPtr' instead + -- since these perform fewer allocations. | CFinalizers (Weak# ()) + -- ^ Finalizers are all C functions. | HaskellFinalizers [IO ()] + -- ^ Finalizers are all Haskell functions. +-- | Controls finalization of a 'ForeignPtr', that is, what should happen +-- if the 'ForeignPtr' becomes unreachable. Visually, these data constructors +-- are appropriate in these scenarios: +-- +-- > Memory backing pointer is +-- > GC-Managed Unmanaged +-- > Finalizer functions are: +------------+-----------------+ +-- > Allowed | MallocPtr | PlainForeignPtr | +-- > +------------+-----------------+ +-- > Prohibited | PlainPtr | FinalPtr | +-- > +------------+-----------------+ data ForeignPtrContents = PlainForeignPtr !(IORef Finalizers) - | MallocPtr (MutableByteArray# RealWorld) !(IORef Finalizers) - | PlainPtr (MutableByteArray# RealWorld) + -- ^ The pointer refers to unmanaged memory that was allocated by + -- a foreign function (typically using @malloc@). The finalizer + -- frequently calls the C function @free@ or some variant of it. + | FinalPtr + -- ^ The pointer refers to unmanaged memory that should not be freed when + -- the 'ForeignPtr' becomes unreachable. Functions that add finalizers + -- to a 'ForeignPtr' throw exceptions when the 'ForeignPtr' is backed by + -- 'PlainPtr'Most commonly, this is used with @Addr#@ literals. + -- See Note [Why FinalPtr]. + -- + -- @since 4.15 + | MallocPtr (MutableByteArray# RealWorld) !(IORef Finalizers) + -- ^ The pointer refers to a byte array. + -- The 'MutableByteArray#' field means that the 'MutableByteArray#' is + -- reachable (by GC) whenever the 'ForeignPtr' is reachable. When the + -- 'ForeignPtr' becomes unreachable, the runtime\'s normal GC recovers + -- the memory backing it. Here, the finalizer function intended to be used + -- to @free()@ any ancilliary *unmanaged* memory pointed to by the + -- 'MutableByteArray#'. See the @zlib@ library for an example of this use. + -- + -- 1. Invariant: The 'Addr#' in the parent 'ForeignPtr' is an interior + -- pointer into this 'MutableByteArray#'. + -- 2. Invariant: The 'MutableByteArray#' is pinned, so the 'Addr#' does not + -- get invalidated by the GC moving the byte array. + -- 3. Invariant: A 'MutableByteArray#' must not be associated with more than + -- one set of finalizers. For example, this is sound: + -- + -- > incrGood :: ForeignPtr Word8 -> ForeignPtr Word8 + -- > incrGood (ForeignPtr p (MallocPtr m f)) = ForeignPtr (plusPtr p 1) (MallocPtr m f) + -- + -- But this is unsound: + -- + -- > incrBad :: ForeignPtr Word8 -> IO (ForeignPtr Word8) + -- > incrBad (ForeignPtr p (MallocPtr m _)) = do + -- > f <- newIORef NoFinalizers + -- > pure (ForeignPtr p (MallocPtr m f)) + | PlainPtr (MutableByteArray# RealWorld) + -- ^ The pointer refers to a byte array. Finalization is not + -- supported. This optimizes @MallocPtr@ by avoiding the allocation + -- of a @MutVar#@ when it is known that no one will add finalizers to + -- the @ForeignPtr@. Functions that add finalizers to a 'ForeignPtr' + -- throw exceptions when the 'ForeignPtr' is backed by 'PlainPtr'. + -- The invariants that apply to 'MallocPtr' apply to 'PlainPtr' as well. + +-- Note [Why FinalPtr] +-- +-- FinalPtr exists as an optimization for foreign pointers created +-- from Addr# literals. Most commonly, this happens in the bytestring +-- library, where the combination of OverloadedStrings and a rewrite +-- rule overloads String literals as ByteString literals. See the +-- rule "ByteString packChars/packAddress" in +-- bytestring:Data.ByteString.Internal. Prior to the +-- introduction of FinalPtr, bytestring used PlainForeignPtr (in +-- Data.ByteString.Internal.unsafePackAddress) to handle such literals. +-- With O2 optimization, the resulting Core from a GHC patched with a +-- known-key cstringLength# function but without FinalPtr looked like: +-- +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +-- stringOne1 = "hello beautiful world"# +-- RHS size: {terms: 11, types: 17, coercions: 0, joins: 0/0} +-- stringOne +-- = case newMutVar# NoFinalizers realWorld# of +-- { (# ipv_i7b6, ipv1_i7b7 #) -> +-- PS stringOne1 (PlainForeignPtr ipv1_i7b7) 0# 21# +-- } +-- +-- After the introduction of FinalPtr, the bytestring library was modified +-- so that the resulting Core was instead: +-- +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +-- stringOne1 = "hello beautiful world"# +-- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} +-- stringOne = PS stringOne1 FinalPtr 0# 21# +-- +-- This improves performance in three ways: +-- +-- 1. More optimization opportunities. GHC is willing to inline the FinalPtr +-- variant of stringOne into its use sites. This means the offset and length +-- are eligible for case-of-known-literal. Previously, this never happened. +-- 2. Smaller binaries. Setting up the thunk to call newMutVar# required +-- machine instruction in the generated code. On x86_64, FinalPtr reduces +-- the size of binaries by about 450 bytes per ByteString literal. +-- 3. Smaller memory footprint. Previously, every ByteString literal resulted +-- in the allocation of a MutVar# and a PlainForeignPtr data constructor. +-- These both hang around until the ByteString goes out of scope. FinalPtr +-- eliminates both of these sources of allocations. The MutVar# is not +-- allocated because FinalPtr does not allow it, and the data constructor +-- is not allocated because FinalPtr is a nullary data constructor. +-- +-- For more discussion of FinalPtr, see GHC MR #2165 and bytestring PR #191. -- | @since 2.01 instance Eq (ForeignPtr a) where @@ -259,7 +372,7 @@ addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO () addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 0# nullAddr# p () MallocPtr _ r -> insertCFinalizer r fp 0# nullAddr# p c - _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer or a final pointer" -- Note [MallocPtr finalizers] (#10904) -- @@ -277,7 +390,7 @@ addForeignPtrFinalizerEnv :: addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 1# ep p () MallocPtr _ r -> insertCFinalizer r fp 1# ep p c - _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer" + _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer or a final pointer" addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO () -- ^This function adds a finalizer to the given @ForeignPtr@. The @@ -319,7 +432,7 @@ addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do finalizer' = unIO (foreignPtrFinalizer r >> touch f) addForeignPtrConcFinalizer_ _ _ = - errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer" + errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to plain pointer or a final pointer" insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do @@ -345,6 +458,8 @@ insertCFinalizer r fp flag ep p val = do -- replaced the content of r before calling finalizeWeak#. (# s1, _ #) -> unIO (insertCFinalizer r fp flag ep p val) s1 +-- Read the weak reference from an IORef Finalizers, creating it if necessary. +-- Throws an exception if HaskellFinalizers is encountered. ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do fin <- readIORef ref @@ -370,6 +485,7 @@ noMixingError = errorWithoutStackTrace $ "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++ "in the same ForeignPtr" +-- Swap out the finalizers with NoFinalizers and then run them. foreignPtrFinalizer :: IORef Finalizers -> IO () foreignPtrFinalizer r = do fs <- atomicSwapIORef r NoFinalizers @@ -455,13 +571,53 @@ plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c -- | Causes the finalizers associated with a foreign pointer to be run --- immediately. +-- immediately. The foreign pointer must not be used again after this +-- function is called. finalizeForeignPtr :: ForeignPtr a -> IO () -finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect -finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers - where - refFinalizers = case foreignPtr of - (PlainForeignPtr ref) -> ref - (MallocPtr _ ref) -> ref - PlainPtr _ -> - errorWithoutStackTrace "finalizeForeignPtr PlainPtr" +finalizeForeignPtr (ForeignPtr _ c) = case c of + PlainForeignPtr ref -> foreignPtrFinalizer ref + MallocPtr _ ref -> foreignPtrFinalizer ref + _ -> errorWithoutStackTrace "finalizeForeignPtr PlainPtr" + +{- $commentary + +This is a high-level overview of how 'ForeignPtr' works. +The implementation of 'ForeignPtr' must accomplish several goals: + +1. Invoke a finalizer once a foreign pointer becomes unreachable. +2. Support augmentation of finalizers, i.e. 'addForeignPtrFinalizer'. + As a motivating example, suppose that the payload of a foreign + pointer is C struct @bar@ that has an optionally NULL pointer field + @foo@ to an unmanaged heap object. Initially, @foo@ is NULL, and + later the program uses @malloc@, initializes the object, and assigns + @foo@ the address returned by @malloc@. When the foreign pointer + becomes unreachable, it is now necessary to first @free@ the object + pointed to by @foo@ and then invoke whatever finalizer was associated + with @bar@. That is, finalizers must be invoked in the opposite order + they are added. +3. Allow users to invoke a finalizer promptly if they know that the + foreign pointer is unreachable, i.e. 'finalizeForeignPtr'. + +How can these goals be accomplished? Goal 1 suggests that weak references +and finalizers (via 'Weak#' and 'mkWeak#') are necessary. But how should +they be used and what should their key be? Certainly not 'ForeignPtr' or +'ForeignPtrContents'. See the warning in "GHC.Weak" about weak pointers with +lifted (non-primitive) keys. The two finalizer-supporting data constructors of +'ForeignPtr' have an @'IORef' 'Finalizers'@ (backed by 'MutVar#') field. +This gets used in two different ways depending on the kind of finalizer: + +* 'HaskellFinalizers': The first @addForeignPtrConcFinalizer_@ call uses + 'mkWeak#' to attach the finalizer @foreignPtrFinalizer@ to the 'MutVar#'. + The resulting 'Weak#' is discarded (see @addForeignPtrConcFinalizer_@). + Subsequent calls to @addForeignPtrConcFinalizer_@ (goal 2) just add + finalizers onto the list in the 'HaskellFinalizers' data constructor. +* 'CFinalizers': The first 'addForeignPtrFinalizer' call uses + 'mkWeakNoFinalizer#' to create a 'Weak#'. The 'Weak#' is preserved in the + 'CFinalizers' data constructor. Both the first call and subsequent + calls (goal 2) use 'addCFinalizerToWeak#' to attach finalizers to the + 'Weak#' itself. Also, see Note [MallocPtr finalizers] for discussion of + the key and value of this 'Weak#'. + +In either case, the runtime invokes the appropriate finalizers when the +'ForeignPtr' becomes unreachable. +-} diff --git a/libraries/ghc-prim/GHC/CString.hs b/libraries/ghc-prim/GHC/CString.hs index 8c0d272a6792ed001e34eb18ec9509e9f7ae4429..514fb0e9f975c3cd02ee5f76f89c1af02c265686 100644 --- a/libraries/ghc-prim/GHC/CString.hs +++ b/libraries/ghc-prim/GHC/CString.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns #-} - +{-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns, UnliftedFFITypes #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.CString @@ -18,7 +17,7 @@ module GHC.CString ( unpackCString#, unpackAppendCString#, unpackFoldrCString#, - unpackCStringUtf8#, unpackNBytes# + unpackCStringUtf8#, unpackNBytes#, cstringLength# ) where import GHC.Types @@ -174,3 +173,17 @@ unpackNBytes# addr len# = unpack [] (len# -# 1#) case indexCharOffAddr# addr i# of ch -> unpack (C# ch : acc) (i# -# 1#) +-- The return type is not correct here. We really want CSize, +-- but that type is defined in base. However, CSize should always +-- match the size of a machine word (I hope), so this is probably +-- alright on all platforms that GHC supports. +foreign import ccall unsafe "strlen" c_strlen :: Addr# -> Int# + +-- | Compute the length of a NUL-terminated string. This address +-- must refer to immutable memory. GHC includes a built-in rule for +-- constant folding when the argument is a statically-known literal. +-- That is, a core-to-core pass reduces the expression +-- @cstringLength# "hello"#@ to the constant @5#@. +cstringLength# :: Addr# -> Int# +{-# INLINE[0] cstringLength# #-} +cstringLength# = c_strlen diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index cf14d21c8129651318aad27742e4688a8537d315..9cfbe99dbe3ce2dbe99550c1ee32f1cac16fc6c8 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -1,3 +1,11 @@ +## 0.6.2 (edit as necessary) + +- Shipped with GHC 8.12.1 + +- Add known-key `cstringLength#` to `GHC.CString`. This is just the + C function `strlen`, but a built-in rewrite rule allows GHC to + compute the result at compile time when the argument is known. + ## 0.6.1 (edit as necessary) - Shipped with GHC 8.10.1 diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 737c9f2385260bb90a374c1989b1073ee660b5d7..76980608c20659a3426a0e3f2b87587f07ecef72 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -43,6 +43,7 @@ Thumbs.db *.prof.sample.normalised *.run.stdout *.run.stderr +*.dump-simpl *.hp tests/**/*.ps diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index abc01fdf95d885b9b13af114e27b38d4750a4729..ad9c0852e9a2d3c201db8ba703e2ab440cc9a80d 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -1344,6 +1344,26 @@ def compile_grep_asm(name: TestName, # no problems found, this test passed return passed() +def compile_grep_core(name: TestName, + way: WayName, + extra_hc_opts: str + ) -> PassFail: + print('Compile only, extra args = ', extra_hc_opts) + result = simple_build(name + '.hs', way, '-ddump-to-file -dsuppress-all -ddump-simpl -O ' + extra_hc_opts, False, None, False, False) + + if badResult(result): + return result + + expected_pat_file = find_expected_file(name, 'substr-simpl') + actual_core_file = add_suffix(name, 'dump-simpl') + + if not grep_output(join_normalisers(normalise_errmsg), + expected_pat_file, actual_core_file): + return failBecause('simplified core mismatch') + + # no problems found, this test passed + return passed() + # ----------------------------------------------------------------------------- # Compile-and-run tests diff --git a/testsuite/tests/primops/should_gen_core/CStringLength_core.hs b/testsuite/tests/primops/should_gen_core/CStringLength_core.hs new file mode 100644 index 0000000000000000000000000000000000000000..98d33d5f51b89dce9bd0bd605f037cfb2297b0a1 --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/CStringLength_core.hs @@ -0,0 +1,11 @@ +{-# language MagicHash #-} + +module CStringLengthCore + ( ozymandias + ) where + +import GHC.Exts + +ozymandias :: Int +ozymandias = + I# (cstringLength# "I met a traveller from an antique land"#) diff --git a/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl b/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl new file mode 100644 index 0000000000000000000000000000000000000000..4b33d6629d9cef0df8dcf91563e0a09c7a47e43e --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/CStringLength_core.substr-simpl @@ -0,0 +1 @@ +I# 38# diff --git a/testsuite/tests/primops/should_gen_core/all.T b/testsuite/tests/primops/should_gen_core/all.T new file mode 100644 index 0000000000000000000000000000000000000000..d66255d8a1ce56426c089d17ed1ee96ee87a75ef --- /dev/null +++ b/testsuite/tests/primops/should_gen_core/all.T @@ -0,0 +1 @@ +test('CStringLength_core', normal, compile_grep_core, ['']) diff --git a/testsuite/tests/primops/should_run/CStringLength.hs b/testsuite/tests/primops/should_run/CStringLength.hs new file mode 100644 index 0000000000000000000000000000000000000000..b580e61934a1872df68ca90ab84fe5af2ae957e3 --- /dev/null +++ b/testsuite/tests/primops/should_run/CStringLength.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +import GHC.Exts + +main :: IO () +main = do + putStr "A: " + print $ + I# (cstringLength# "hello_world"#) + == + naiveStrlen "hello_world"# 0 + putStr "B: " + print $ + I# (cstringLength# "aaaaaaaaaaaaa\x00b"#) + == + naiveStrlen "aaaaaaaaaaaaa\x00b"# 0 + putStr "C: " + print $ + I# (cstringLength# "cccccccccccccccccc\x00b"#) + == + naiveStrlen "cccccccccccccccccc\x00b"# 0 + putStr "D: " + print $ + I# (cstringLength# "araña\NULb"#) + == + naiveStrlen "araña\NULb"# 0 + +naiveStrlen :: Addr# -> Int -> Int +naiveStrlen addr !n = case indexWord8OffAddr# addr 0# of + 0## -> n + _ -> naiveStrlen (plusAddr# addr 1#) (n + 1) diff --git a/testsuite/tests/primops/should_run/CStringLength.stdout b/testsuite/tests/primops/should_run/CStringLength.stdout new file mode 100644 index 0000000000000000000000000000000000000000..9413913c01a3812d51e3bcc953155269029583cc --- /dev/null +++ b/testsuite/tests/primops/should_run/CStringLength.stdout @@ -0,0 +1,4 @@ +A: True +B: True +C: True +D: True diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index 16579207faa41fc5fb60267766d7af777d8c18f7..952145fd49a31dffa92aa2db58b5e5a965584537 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -29,3 +29,4 @@ test('CmpWord16', normal, compile_and_run, ['']) test('ShrinkSmallMutableArrayA', normal, compile_and_run, ['']) test('ShrinkSmallMutableArrayB', normal, compile_and_run, ['']) test('T14664', normal, compile_and_run, ['']) +test('CStringLength', normal, compile_and_run, ['-O2'])