%
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
-\section{Primitive operations for packed strings}
+\section{Basic ops on packed representations}
-Core operations for working on a chunk of bytes.
-These operations is the core set needed by the
-GHC internally, the code generator and the prelude
-libraries.
+Some basic operations for working on packed representations of series
+of bytes (character strings). Used by the interface lexer input
+subsystem, mostly.
\begin{code}
-#include "HsVersions.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
- --packString2, -- :: Addr -> Int -> _ByteArray Int
- stringToByteArray, -- :: String -> _ByteArray Int
- byteArrayToString, -- :: _ByteArray Int -> String
+ 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
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
-#if __GLASGOW_HASKELL__ <= 201
-import PreludeGlaST
-import PreludeGlaMisc
-#else
+-- This #define suppresses the "import FastString" that
+-- HsVersions otherwise produces
+#define COMPILING_FAST_STRING
+#include "HsVersions.h"
+
import GlaExts
-import Foreign
-import GHC
-import ArrBase
+import Addr ( Addr(..) )
import 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#(..) )
+import PrelST
+#else
+import PrelST
#endif
\end{code}
Return the length of a @\\NUL@ terminated character string:
\begin{code}
-strLength :: _Addr -> Int
+strLength :: Addr -> Int
strLength a =
- unsafePerformPrimIO (
- _ccall_ strlen a `thenPrimIO` \ len@(I# _) ->
- returnPrimIO len
+ unsafePerformIO (
+ _ccall_ strlen a >>= \ len@(I# _) ->
+ return len
)
\end{code}
NULs.
\begin{code}
-copyPrefixStr :: _Addr -> Int -> _ByteArray Int
+copyPrefixStr :: Addr -> Int -> ByteArray Int
copyPrefixStr (A# a) len@(I# length#) =
- unsafePerformPrimIO (
+ runST (
{- allocate an array that will hold the string
(not forgetting the NUL at the end)
-}
- (new_ps_array (length# +# 1#)) `thenPrimIO` \ ch_array ->
- _ccall_ memcpy ch_array (A# a) len `thenPrimIO` \ () ->
- write_ps_array ch_array length# (chr# 0#) `seqPrimIO`
+ (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# `seqPrimIO`
+ fill_in ch_array 0# >>
-- freeze the puppy:
- freeze_ps_array ch_array)
+ freeze_ps_array ch_array length# `thenStrictlyST` \ barr ->
+ returnStrictlyST barr )
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
(and positive lengths, thank you).
\begin{code}
-copySubStr :: _Addr -> Int -> Int -> _ByteArray Int
+copySubStr :: Addr -> Int -> Int -> ByteArray Int
copySubStr a start length =
- unsafePerformPrimIO (
- _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start `thenPrimIO` \ a_start ->
- returnPrimIO (copyPrefixStr a_start length))
+ unsafePerformIO (
+ _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
+ >>= \ a_start ->
+ return (copyPrefixStr a_start length))
\end{code}
-Copying a sub-string out of a ForeignObj
+pCopying a sub-string out of a ForeignObj
\begin{code}
-copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int
-copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
- unsafePerformPrimIO (
+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)
-}
-- fill in packed string from "addr"
fill_in ch_array 0# `seqStrictlyST`
-- freeze the puppy:
- freeze_ps_array ch_array)
+ freeze_ps_array ch_array length#)
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ 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 ->
+ = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
write_ps_array arr_in# idx ch `seqStrictlyST`
fill_in arr_in# (idx +# 1#) }
-{- ToDo: add FO primitives.. -}
-indexCharOffFO# :: ForeignObj# -> Int# -> Char#
-indexCharOffFO# fo# i# =
- case unsafePerformPrimIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (_ForeignObj fo#) (I# i#)) of
- C# c -> c
-
+-- step on (char *) pointer by x units.
addrOffset# :: Addr# -> Int# -> Addr#
addrOffset# a# i# =
- case unsafePerformPrimIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
+ 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#) =
- unsafePerformPrimIO (
+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`
+ fill_in ch_array 0# `seqStrictlyST`
-- freeze the puppy:
- freeze_ps_array ch_array)
+ freeze_ps_array ch_array length#)
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
\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 -> _ST s (_ByteArray Int)
+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 size =
- MkST ( \ (S# s) ->
+new_ps_array size = ST $ \ s ->
+#if __GLASGOW_HASKELL__ < 400
case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, S# s2#)})
+ STret s2# (MutableByteArray bot barr#) }
+#else
+ case (newCharArray# size s) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray bot barr# #) }
+#endif
+ where
+ bot = error "new_ps_array"
-write_ps_array (_MutableByteArray _ barr#) n ch =
- MkST ( \ (S# s#) ->
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
- ((), S# s2#)})
+#if __GLASGOW_HASKELL__ < 400
+ STret s2# () }
+#else
+ (# s2#, () #) }
+#endif
-- same as unsafeFreezeByteArray
-freeze_ps_array (_MutableByteArray ixs arr#) =
- MkST ( \ (S# s#) ->
+freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
+#if __GLASGOW_HASKELL__ < 400
case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) })
+ STret s2# (ByteArray (0,I# len#) frozen#) }
+#else
+ case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+ (# s2#, ByteArray (0,I# len#) frozen# #) }
+#endif
\end{code}
+
Compare two equal-length strings for equality:
\begin{code}
eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefix a# barr# len# =
- unsafePerformPrimIO (
- _ccall_ strncmp (A# a#) (_ByteArray bottom barr#) (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ unsafePerformIO (
+ _ccall_ strncmp (A# a#) (ByteArray bottom barr#) (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefix"
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
- unsafePerformPrimIO (
- _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
- where
- bottom :: (Int,Int)
- bottom = error "eqStrPrefix"
+ unsafePerformIO (
+ _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ByteArray bottom b2#)
+ (ByteArray bottom b2#)
(I# start#)
- (_ByteArray bottom b1#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (ByteArray bottom b1#)
+ (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefixBA"
eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
eqCharStrPrefixBA a# b2# start# len# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ByteArray bottom b2#)
+ (ByteArray bottom b2#)
(I# start#)
(A# a#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (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# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ForeignObj fo#)
+ (ForeignObj fo#)
(I# start#)
- (_ByteArray bottom barr#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (ByteArray bottom barr#)
+ (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefixFO"
\end{code}
-
-\begin{code}
-byteArrayToString :: _ByteArray Int -> String
-byteArrayToString (_ByteArray (I# start#,I# end#) barr#) =
- unpack start#
- where
- unpack nh#
- | nh# >=# end# = []
- | otherwise = C# ch : unpack (nh# +# 1#)
- where
- ch = indexCharArray# barr# nh#
-
-\end{code}
-
-
-\begin{code}
-stringToByteArray :: String -> (_ByteArray Int)
-stringToByteArray str = _runST (packStringST str)
-
-packStringST :: [Char] -> _ST s (_ByteArray Int)
-packStringST str =
- let len = length str in
- packNCharsST len str
-
-packNCharsST :: Int -> [Char] -> _ST s (_ByteArray Int)
-packNCharsST len@(I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str `seqStrictlyST`
- -- freeze the puppy:
- freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) ->
- returnStrictlyST (_ByteArray (0,len) frozen#)
- where
- fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c `seqStrictlyST`
- fill_in arr_in# (idx +# 1#) cs
-
-\end{code}
-
-
projects / ghc-hetmet.git / blobdiff