subsystem, mostly.
\begin{code}
-module PrimPacked
- (
- strLength, -- :: _Addr -> Int
- copyPrefixStr, -- :: _Addr -> Int -> ByteArray Int
- copySubStr, -- :: _Addr -> Int -> Int -> ByteArray Int
- copySubStrFO, -- :: ForeignObj -> Int -> Int -> ByteArray Int
- copySubStrBA, -- :: ByteArray Int -> Int -> Int -> ByteArray Int
-
- eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
- eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
- eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
- eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
- eqStrPrefixFO, -- :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
-
- addrOffset# -- :: Addr# -> Int# -> Addr#
- ) where
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module PrimPacked (
+ Ptr(..), nullPtr, plusAddr#,
+ BA(..),
+ packString, -- :: String -> (Int, BA)
+ unpackNBytesBA, -- :: BA -> Int -> [Char]
+ strLength, -- :: Ptr CChar -> Int
+ copyPrefixStr, -- :: Addr# -> Int -> BA
+ copySubStrBA, -- :: BA -> Int -> Int -> BA
+ eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
+ eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
+ ) where
-- This #define suppresses the "import FastString" that
-- HsVersions otherwise produces
#define COMPILING_FAST_STRING
#include "HsVersions.h"
-import GlaExts
-import Addr ( Addr(..) )
-import ST
+import GLAEXTS
+import UNSAFE_IO ( unsafePerformIO )
+
+import MONAD_ST
import Foreign
--- ForeignObj is now exported abstractly.
-#if __GLASGOW_HASKELL__ >= 303
-import PrelForeign ( ForeignObj(..) )
-#endif
-#if __GLASGOW_HASKELL__ < 301
-import ArrBase ( StateAndMutableByteArray#(..),
- StateAndByteArray#(..) )
-import STBase
-#elif __GLASGOW_HASKELL__ < 400
-import PrelArr ( StateAndMutableByteArray#(..),
- StateAndByteArray#(..) )
+#if __GLASGOW_HASKELL__ < 503
import PrelST
#else
-import PrelST
+import GHC.ST
#endif
-\end{code}
+#if __GLASGOW_HASKELL__ >= 504
+import GHC.Ptr ( Ptr(..) )
+#elif __GLASGOW_HASKELL__ >= 500
+import Ptr ( Ptr(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ < 504
+import PrelIOBase ( IO(..) )
+#else
+import GHC.IOBase ( IO(..) )
+#endif
+\end{code}
-Return the length of a @\\NUL@ terminated character string:
+Compatibility: 4.08 didn't have the Ptr type.
\begin{code}
-strLength :: Addr -> Int
-strLength a =
- unsafePerformIO (
- _ccall_ strlen a >>= \ len@(I# _) ->
- return len
- )
-{-# NOINLINE strLength #-}
+#if __GLASGOW_HASKELL__ <= 408
+data Ptr a = Ptr Addr# deriving (Eq, Ord)
+
+nullPtr :: Ptr a
+nullPtr = Ptr (int2Addr# 0#)
+#endif
+
+#if __GLASGOW_HASKELL__ <= 500
+-- plusAddr# is a primop in GHC > 5.00
+plusAddr# :: Addr# -> Int# -> Addr#
+plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
+#endif
\end{code}
-Copying a char string prefix into a byte array,
-{\em assuming} the prefix does not contain any
-NULs.
+Wrapper types for bytearrays
\begin{code}
-copyPrefixStr :: Addr -> Int -> ByteArray Int
-copyPrefixStr (A# a) len@(I# length#) =
- runST (
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- (new_ps_array (length# +# 1#)) >>= \ ch_array ->
-{- 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 packed string from "addr"
- fill_in ch_array 0# >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# `thenStrictlyST` \ barr ->
- returnStrictlyST barr )
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
- | idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
- | otherwise
- = case (indexCharOffAddr# a idx) of { ch ->
- write_ps_array arr_in# idx ch `seqStrictlyST`
- fill_in arr_in# (idx +# 1#) }
+data BA = BA ByteArray#
+data MBA s = MBA (MutableByteArray# s)
+\end{code}
+\begin{code}
+packString :: String -> (Int, BA)
+packString str = (l, arr)
+ where
+ l@(I# length#) = length str
+
+ arr = runST (do
+ ch_array <- new_ps_array length#
+ -- fill in packed string from "str"
+ fill_in ch_array 0# str
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> [Char] -> ST s ()
+ fill_in arr_in# idx [] =
+ return ()
+ fill_in arr_in# idx (C# c : cs) =
+ write_ps_array arr_in# idx c >>
+ fill_in arr_in# (idx +# 1#) cs
\end{code}
-Copying out a substring, assume a 0-indexed string:
-(and positive lengths, thank you).
+Unpacking a string
\begin{code}
-copySubStr :: Addr -> Int -> Int -> ByteArray Int
-copySubStr a start length =
- unsafePerformIO (
- _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
- >>= \ a_start ->
- return (copyPrefixStr a_start length))
+unpackNBytesBA :: BA -> Int -> [Char]
+unpackNBytesBA (BA bytes) (I# len)
+ = unpack 0#
+ where
+ unpack nh
+ | nh >=# len = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharArray# bytes nh
\end{code}
-pCopying a sub-string out of a ForeignObj
+Copying a char string prefix into a byte array.
\begin{code}
-copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int
-copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) =
- runST (
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
- -- fill in packed string from "addr"
- fill_in ch_array 0# `seqStrictlyST`
- -- freeze the puppy:
- freeze_ps_array ch_array length#)
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
+copyPrefixStr :: Addr# -> Int -> BA
+copyPrefixStr a# len@(I# length#) = copy' length#
+ where
+ copy' length# = runST (do
+ {- allocate an array that will hold the string
+ -}
+ 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 packed string from "addr"
+ fill_in ch_array 0#
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> ST s ()
+ fill_in arr_in# idx
| idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
+ = return ()
| otherwise
- = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
- write_ps_array arr_in# idx ch `seqStrictlyST`
+ = case (indexCharOffAddr# a# idx) of { ch ->
+ write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
+\end{code}
+
+Copying out a substring, assume a 0-indexed string:
+(and positive lengths, thank you).
--- step on (char *) pointer by x units.
-addrOffset# :: Addr# -> Int# -> Addr#
-addrOffset# a# i# =
- case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
- A# a -> a
-
-copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
-copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
- runST (
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
- -- fill in packed string from "addr"
- fill_in ch_array 0# `seqStrictlyST`
- -- freeze the puppy:
- freeze_ps_array ch_array length#)
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
+\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
+ ch_array <- new_ps_array length#
+ -- fill in packed string from "addr"
+ fill_in ch_array 0#
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> ST s ()
+ fill_in arr_in# idx
| idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
+ = return ()
| otherwise
= case (indexCharArray# barr# (start# +# idx)) of { ch ->
- write_ps_array arr_in# idx ch `seqStrictlyST`
+ write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
-
\end{code}
(Very :-) ``Specialised'' versions of some CharArray things...
[Copied from PackBase; no real reason -- UGH]
\begin{code}
-new_ps_array :: Int# -> ST s (MutableByteArray s Int)
-write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
-freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
+new_ps_array :: Int# -> ST s (MBA s)
+write_ps_array :: MBA s -> Int# -> Char# -> ST s ()
+freeze_ps_array :: MBA s -> Int# -> ST s BA
+
+#if __GLASGOW_HASKELL__ < 411
+#define NEW_BYTE_ARRAY newCharArray#
+#else
+#define NEW_BYTE_ARRAY newPinnedByteArray#
+#endif
new_ps_array size = ST $ \ s ->
-#if __GLASGOW_HASKELL__ < 400
- case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray bot barr#) }
-#else
- case (newCharArray# size s) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot barr# #) }
-#endif
- where
- bot = error "new_ps_array"
+ case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) ->
+ (# s2#, MBA barr# #) }
-write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
+write_ps_array (MBA barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
-#if __GLASGOW_HASKELL__ < 400
- STret s2# () }
-#else
(# s2#, () #) }
-#endif
-- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
-#if __GLASGOW_HASKELL__ < 400
- case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray (0,I# len#) frozen#) }
-#else
+freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray (0,I# len#) frozen# #) }
-#endif
+ (# s2#, BA frozen# #) }
\end{code}
\begin{code}
eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefix a# barr# len# =
- unsafePerformIO (
- _ccall_ strncmp (A# a#) (ByteArray bottom barr#) (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqStrPrefix"
+ inlinePerformIO $ do
+ x <- memcmp_ba a# barr# (I# len#)
+ return (x == 0)
+#ifdef UNUSED
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
- unsafePerformIO (
- _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
+ inlinePerformIO $ do
+ x <- memcmp a1# a2# (I# len#)
+ return (x == 0)
+#endif
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
- unsafePerformIO (
- _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (ByteArray bottom b2#)
- (I# start#)
- (ByteArray bottom b1#)
- (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqStrPrefixBA"
+ 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 (
- _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (ByteArray bottom b2#)
- (I# start#)
- (A# a#)
- (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqCharStrPrefixBA"
-
-eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
-eqStrPrefixFO fo# barr# start# len# =
- unsafePerformIO (
- _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (ForeignObj fo#)
- (I# start#)
- (ByteArray bottom barr#)
- (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqStrPrefixFO"
+ 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 unsafe "ghc_strlen"
+ ghc_strlen :: Addr# -> Int
+#else
+foreign import ccall unsafe "ghc_strlen"
+ strLength :: Ptr () -> Int
+#endif
+
+foreign import ccall unsafe "ghc_memcmp"
+ memcmp :: Addr# -> Addr# -> Int -> IO Int
+
+foreign import ccall unsafe "ghc_memcmp"
+ memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
+
+foreign import ccall unsafe "ghc_memcmp_off"
+ memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
+
+foreign import ccall unsafe "ghc_memcmp_off"
+ memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff