X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FPrimPacked.lhs;h=f2d034dcee619b86e0b92fd5fb78763130cdaf86;hb=2a2efb720c0fdc06fe749f96f284b00b30f8f3f7;hp=10216452f639dcb9c9825f9f06862a783c3704b9;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs
index 1021645..f2d034d 100644
--- a/ghc/compiler/utils/PrimPacked.lhs
+++ b/ghc/compiler/utils/PrimPacked.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
 %
 \section{Basic ops on packed representations}
 
@@ -8,188 +8,198 @@ of bytes (character strings). Used by the interface lexer input
 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# 
-        indexCharOffFO#     -- :: ForeignObj# -> Int# -> Char#
-       ) 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 GHC
-import ArrBase
-import ST
-import STBase
-import IOBase	( ForeignObj(..) )
-import PackBase ( unpackCStringBA, packString )
-\end{code} 
+import GLAEXTS
+import UNSAFE_IO	( unsafePerformIO )
 
-Return the length of a @\\NUL@ terminated character string:
+import MONAD_ST
+import Foreign
+
+#if __GLASGOW_HASKELL__ < 503
+import PrelST
+#else
+import GHC.ST
+#endif
+
+#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}
+
+Compatibility: 4.08 didn't have the Ptr type.
 
 \begin{code}
-strLength :: Addr -> Int
-strLength a =
- unsafePerformIO (
-    _ccall_ strlen a  >>= \ len@(I# _) ->
-    return len
- )
+#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 (indexCharOffFO# 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}
 
-{- 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
+Copying out a substring, assume a 0-indexed string:
+(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
 
--- 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
+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 ->
-    case (newCharArray# size s)	  of { StateAndMutableByteArray# s2# barr# ->
-    STret s2# (MutableByteArray bot barr#) }
-  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#   ->
-    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 (MBA arr#) len# = ST $ \ s# ->
+    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+    (# s2#, BA frozen# #) }
 \end{code}
 
 
@@ -198,69 +208,58 @@ Compare two equal-length strings for equality:
 \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#))
-  where
-   bottom :: (Int,Int)
-   bottom = error "eqStrPrefix"
+  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}
-byteArrayToString :: ByteArray Int -> String
-byteArrayToString = unpackCStringBA
-\end{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
 
-\begin{code}
-stringToByteArray :: String -> (ByteArray Int)
-stringToByteArray = packString
+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}