X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FPrimPacked.lhs;h=aa38d6a13016bfd710c7d1a9af4cbf7809a95572;hb=8ab73b40ac2ac5861b4dd03a50e4624ce3b0d024;hp=5c3715b9184a7069a5d55abd902a4c81ad820495;hpb=2773693e5f92c285ef17aa8720d89ce8689add6e;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs
index 5c3715b..aa38d6a 100644
--- a/ghc/compiler/utils/PrimPacked.lhs
+++ b/ghc/compiler/utils/PrimPacked.lhs
@@ -1,26 +1,20 @@
 %
-% (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
@@ -28,23 +22,33 @@ module PrimPacked
         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 PrelAddr	( Addr(..) )
 import ST
-import STBase
-#if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char(..) )
+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} 
@@ -52,13 +56,13 @@ import PrelBase ( Char(..) )
 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
  )
-
+{-# NOINLINE strLength #-}
 \end{code}
 
 Copying a char string prefix into a byte array,
@@ -66,21 +70,24 @@ Copying a char string prefix into a byte array,
 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#
@@ -97,19 +104,20 @@ Copying out a substring, assume a 0-indexed string:
 (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)
   -}
@@ -117,43 +125,42 @@ copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
    -- 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
+#if __GLASGOW_HASKELL__ >= 405
+copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
+#else
+copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
+#endif
+ 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#
@@ -167,135 +174,148 @@ copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# 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#) }
+#elif __GLASGOW_HASKELL__ < 405
+    case (newCharArray# size s)	  of { (# s2#, barr# #) ->
+    (# s2#, MutableByteArray bot barr# #) }
+#else
+    case (newCharArray# size s)	  of { (# s2#, barr# #) ->
+    (# s2#, MutableByteArray bot bot barr# #) }
+#endif
+  where
+    bot = error "new_ps_array"
 
-write_ps_array (_MutableByteArray _ barr#) n ch =
-    MkST ( \ (S# s#) ->
+#if __GLASGOW_HASKELL__ < 400
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
+    case writeCharArray# barr# n ch s#	of { s2#   ->
+    STret s2# () }
+#elif __GLASGOW_HASKELL__ < 405
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
+    case writeCharArray# barr# n ch s#	of { s2#   ->
+    (# s2#, () #) }
+#else
+write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
     case writeCharArray# barr# n ch s#	of { s2#   ->
-    ((), S# s2#)})
+    (# s2#, () #) }
+#endif
 
 -- same as unsafeFreezeByteArray
-freeze_ps_array (_MutableByteArray ixs arr#) =
-    MkST ( \ (S# s#) ->
+#if __GLASGOW_HASKELL__ < 400
+freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
-    (_ByteArray ixs frozen#, S# s2#) })
+    STret s2# (ByteArray (0,I# len#) frozen#) }
+#elif __GLASGOW_HASKELL__ < 405
+freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
+    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
+    (# s2#, ByteArray (0,I# len#) frozen# #) }
+#else
+freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
+    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 (
+#if __GLASGOW_HASKELL__ < 405
+   _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) ->
+#else
+   _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
+#endif
+   return (x# ==# 0#))
   where
-   bottom :: (Int,Int)
-   bottom = error "eqStrPrefix"
+#if __GLASGOW_HASKELL__ < 405
+   bot :: (Int,Int)
+#else
+   bot :: Int
+#endif
+   bot = 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#) 
+#if __GLASGOW_HASKELL__ < 405
+	  (ByteArray bot b2#)
+#else
+	  (ByteArray bot bot b2#) 
+#endif 
 	  (I# start#) 
-          (_ByteArray bottom b1#) 
-          (I# len#)                  `thenPrimIO` \ (I# x#) ->
-   returnPrimIO (x# ==# 0#))
+#if __GLASGOW_HASKELL__ < 405
+          (ByteArray bot b1#) 
+#else
+          (ByteArray bot bot b1#) 
+#endif
+          (I# len#)                  >>= \ (I# x#) ->
+   return (x# ==# 0#))
   where
-   bottom :: (Int,Int)
-   bottom = error "eqStrPrefixBA"
+#if __GLASGOW_HASKELL__ < 405
+   bot :: (Int,Int)
+#else
+   bot :: Int
+#endif
+   bot = 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#) 
+#if __GLASGOW_HASKELL__ < 405
+	  (ByteArray bot b2#) 
+#else
+	  (ByteArray bot bot b2#) 
+#endif
 	  (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"
+#if __GLASGOW_HASKELL__ < 405
+   bot :: (Int,Int)
+#else
+   bot :: Int
+#endif
+   bot = 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#))
+#if __GLASGOW_HASKELL__ < 405
+          (ByteArray bot barr#) 
+#else
+          (ByteArray bot bot barr#) 
+#endif
+          (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
-
+#if __GLASGOW_HASKELL__ < 405
+   bot :: (Int,Int)
+#else
+   bot :: Int
+#endif
+   bot = error "eqStrPrefixFO"
 \end{code}
-
-