%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
\section{Basic ops on packed representations}
subsystem, mostly.
\begin{code}
+{-# OPTIONS -monly-3-regs -optc-DNON_POSIX_SOURCE -#include "hschooks.h" #-}
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#
- indexCharOffFO# -- :: ForeignObj# -> Int# -> Char#
+ addrOffset# -- :: Addr# -> Int# -> Addr#
) where
-- This #define suppresses the "import FastString" that
#include "HsVersions.h"
import GlaExts
+#if __GLASGOW_HASKELL__ < 411
+import PrelAddr ( Addr(..) )
+#else
import Addr ( Addr(..) )
-import GHC
-import ArrBase
+#endif
import ST
-import STBase
-import IOBase ( ForeignObj(..) )
-import PackBase ( unpackCStringBA, packString )
-\end{code}
-
-Return the length of a @\\NUL@ terminated character string:
+import Foreign
-\begin{code}
-strLength :: Addr -> Int
-strLength a =
- unsafePerformIO (
- _ccall_ strlen a >>= \ len@(I# _) ->
- return len
- )
+#if __GLASGOW_HASKELL__ < 503
+import PrelST
+#else
+import GHC.ST
+#endif
\end{code}
-- fill in packed string from "addr"
fill_in ch_array 0# >>
-- freeze the puppy:
- freeze_ps_array ch_array length# `thenStrictlyST` \ barr ->
- returnStrictlyST barr )
+ freeze_ps_array ch_array length# >>= \ barr ->
+ return 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 ()
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
| otherwise
= case (indexCharOffAddr# a 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}
_casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
>>= \ a_start ->
return (copyPrefixStr a_start length))
-\end{code}
-
-pCopying a sub-string out of a ForeignObj
-
-\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
- | idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
- | otherwise
- = case (indexCharOffFO# fo (idx +# start#)) of { ch ->
- write_ps_array arr_in# idx ch `seqStrictlyST`
- fill_in arr_in# (idx +# 1#) }
-
-{- ToDo: add FO primitives.. -}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <=205
-indexCharOffFO# :: ForeignObj# -> Int# -> Char#
-indexCharOffFO# fo# i# =
- case unsafePerformIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (ForeignObj fo#) (I# i#)) of
- C# c -> c
-#else
-indexCharOffFO# :: ForeignObj# -> Int# -> Char#
-indexCharOffFO# fo i = indexCharOffForeignObj# fo i
-#endif
-- step on (char *) pointer by x units.
addrOffset# :: Addr# -> Int# -> Addr#
A# a -> a
copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
-copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
+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 ->
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
-- fill in packed string from "addr"
- fill_in ch_array 0# `seqStrictlyST`
+ fill_in ch_array 0# >>
-- freeze the puppy:
freeze_ps_array ch_array length#)
where
fill_in arr_in# idx
| idx ==# length#
- = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ 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...
freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
new_ps_array size = ST $ \ s ->
- case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
- STret s2# (MutableByteArray bot barr#) }
+#if __GLASGOW_HASKELL__ < 411
+ case (newCharArray# size s) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot bot barr# #) }
+#else /* 411 and higher */
+ case (newByteArray# size s) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot bot barr# #) }
+#endif
where
bot = error "new_ps_array"
-write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
+write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
- STret s2# () }
+ (# s2#, () #) }
-- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
- case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- STret s2# (ByteArray (0,I# len#) frozen#) }
+freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray 0 (I# len#) 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"
+ unsafePerformIO $ do
+ x <- memcmp_ba a# barr# (I# len#)
+ return (x == 0)
+-- unused???
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
- unsafePerformIO (
- _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
- return (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqStrPrefix"
+ unsafePerformIO $ do
+ x <- memcmp a1# a2# (I# len#)
+ return (x == 0)
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"
+ unsafePerformIO $ do
+ x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
+ return (x == 0)
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"
+ unsafePerformIO $ do
+ x <- memcmp_baoff b2# (I# start#) a# (I# len#)
+ return (x == 0)
\end{code}
\begin{code}
-byteArrayToString :: ByteArray Int -> String
-byteArrayToString = unpackCStringBA
-\end{code}
+foreign import ccall "ghc_strlen" unsafe
+ strLength :: Addr -> Int
+foreign import ccall "ghc_memcmp" unsafe
+ memcmp :: Addr# -> Addr# -> Int -> IO Int
-\begin{code}
-stringToByteArray :: String -> (ByteArray Int)
-stringToByteArray = packString
+foreign import ccall "ghc_memcmp" unsafe
+ memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
+
+foreign import ccall "ghc_memcmp_off" unsafe
+ memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
+
+foreign import ccall "ghc_memcmp_off" unsafe
+ memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff