{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module PrimPacked (
- Ptr(..), nullPtr, writeCharOffPtr, plusAddr#,
- BA(..), MBA(..),
+ Ptr(..), nullPtr, plusAddr#,
+ BA(..),
packString, -- :: String -> (Int, BA)
- unpackCStringBA, -- :: BA -> Int -> [Char]
+ unpackNBytesBA, -- :: BA -> Int -> [Char]
strLength, -- :: Ptr CChar -> Int
copyPrefixStr, -- :: Addr# -> Int -> BA
- copySubStr, -- :: Addr# -> Int -> Int -> BA
copySubStrBA, -- :: BA -> Int -> Int -> BA
eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
- eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
- eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
) where
-- This #define suppresses the "import FastString" that
plusAddr# :: Addr# -> Int# -> Addr#
plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
#endif
-
--- more compatibility: in 5.00+ we would use the Storable class for this,
--- but 4.08 doesn't have it.
-writeCharOffPtr (Ptr a#) (I# i#) (C# c#) = IO $ \s# ->
- case writeCharOffAddr# a# i# c# s# of { s# -> (# s#, () #) }
\end{code}
Wrapper types for bytearrays
l@(I# length#) = length str
arr = runST (do
- ch_array <- new_ps_array (length# +# 1#)
+ ch_array <- new_ps_array length#
-- fill in packed string from "str"
fill_in ch_array 0# str
-- freeze the puppy:
fill_in :: MBA s -> Int# -> [Char] -> ST s ()
fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) >>
return ()
-
fill_in arr_in# idx (C# c : cs) =
write_ps_array arr_in# idx c >>
fill_in arr_in# (idx +# 1#) cs
Unpacking a string
\begin{code}
-unpackCStringBA :: BA -> Int -> [Char]
-unpackCStringBA (BA bytes) (I# len)
+unpackNBytesBA :: BA -> Int -> [Char]
+unpackNBytesBA (BA bytes) (I# len)
= unpack 0#
where
unpack nh
- | nh >=# len ||
- ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
+ | nh >=# len = []
+ | otherwise = C# ch : unpack (nh +# 1#)
where
ch = indexCharArray# bytes nh
\end{code}
-Copying a char string prefix into a byte array,
-{\em assuming} the prefix does not contain any
-NULs.
+Copying a char string prefix into a byte array.
\begin{code}
copyPrefixStr :: Addr# -> Int -> BA
where
copy' length# = runST (do
{- allocate an array that will hold the string
- (not forgetting the NUL at the end)
-}
- ch_array <- new_ps_array (length# +# 1#)
+ ch_array <- new_ps_array length#
{- Revert back to Haskell-only solution for the moment.
_ccall_ memcpy ch_array (A# a) len >>= \ () ->
write_ps_array ch_array length# (chr# 0#) >>
fill_in :: MBA s -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
+ = return ()
| otherwise
= case (indexCharOffAddr# a# idx) of { ch ->
write_ps_array arr_in# idx ch >>
(and positive lengths, thank you).
\begin{code}
+#ifdef UNUSED
copySubStr :: Addr# -> Int -> Int -> BA
copySubStr a# (I# start#) length =
copyPrefixStr (a# `plusAddr#` start#) length
+#endif
copySubStrBA :: BA -> Int -> Int -> BA
copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
where
ba = runST (do
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- ch_array <- new_ps_array (length# +# 1#)
+ -- allocate an array that will hold the string
+ ch_array <- new_ps_array length#
-- fill in packed string from "addr"
fill_in ch_array 0#
-- freeze the puppy:
fill_in :: MBA s -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) >>
- return ()
+ = return ()
| otherwise
= case (indexCharArray# barr# (start# +# idx)) of { ch ->
write_ps_array arr_in# idx ch >>
#if __GLASGOW_HASKELL__ < 411
#define NEW_BYTE_ARRAY newCharArray#
#else
-#define NEW_BYTE_ARRAY newByteArray#
+#define NEW_BYTE_ARRAY newPinnedByteArray#
#endif
new_ps_array size = ST $ \ s ->
\begin{code}
eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefix a# barr# len# =
- unsafePerformIO $ do
+ inlinePerformIO $ do
x <- memcmp_ba a# barr# (I# len#)
return (x == 0)
--- unused???
+#ifdef UNUSED
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
- unsafePerformIO $ do
+ inlinePerformIO $ do
x <- memcmp a1# a2# (I# len#)
return (x == 0)
+#endif
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
- unsafePerformIO $ do
+ inlinePerformIO $ do
x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
return (x == 0)
+#ifdef UNUSED
eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
eqCharStrPrefixBA a# b2# start# len# =
- unsafePerformIO $ do
+ inlinePerformIO $ do
x <- memcmp_baoff b2# (I# start#) a# (I# len#)
return (x == 0)
+#endif
\end{code}
\begin{code}
+-- Just like unsafePerformIO, but we inline it. This is safe when
+-- there are no side effects, and improves performance.
+{-# INLINE inlinePerformIO #-}
+inlinePerformIO :: IO a -> a
+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
+
#if __GLASGOW_HASKELL__ <= 408
strLength (Ptr a#) = ghc_strlen a#
-foreign import ccall "ghc_strlen" unsafe
+foreign import ccall unsafe "ghc_strlen"
ghc_strlen :: Addr# -> Int
#else
-foreign import ccall "ghc_strlen" unsafe
+foreign import ccall unsafe "ghc_strlen"
strLength :: Ptr () -> Int
#endif
-foreign import ccall "ghc_memcmp" unsafe
+foreign import ccall unsafe "ghc_memcmp"
memcmp :: Addr# -> Addr# -> Int -> IO Int
-foreign import ccall "ghc_memcmp" unsafe
+foreign import ccall unsafe "ghc_memcmp"
memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
-foreign import ccall "ghc_memcmp_off" unsafe
+foreign import ccall unsafe "ghc_memcmp_off"
memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
-foreign import ccall "ghc_memcmp_off" unsafe
+foreign import ccall unsafe "ghc_memcmp_off"
memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff