From a943fcfeff7b2b0e81a25f348eeb0d1c31e0d7d6 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Mon, 24 Nov 1997 20:04:55 +0000
Subject: [PATCH] [project @ 1997-11-24 20:04:49 by sof] Misc changes to
 compile with new defns of ST, IO (and PrimIO)

---
 ghc/compiler/utils/Digraph.lhs      |    4 ++++
 ghc/compiler/utils/FastString.lhs   |   28 ++++++++++++++++++++-------
 ghc/compiler/utils/Outputable.lhs   |    4 ++++
 ghc/compiler/utils/PrimPacked.lhs   |   36 ++++++++++++++++++-----------------
 ghc/compiler/utils/SST.lhs          |   10 +++++++++-
 ghc/compiler/utils/StringBuffer.lhs |    3 +++
 6 files changed, 60 insertions(+), 25 deletions(-)

diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index d49bd97..3c69ce2 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -41,6 +41,10 @@ import ST
 import ArrBase
 import Maybe
 
+# if __GLASGOW_HASKELL__ >= 209
+import GlaExts ( thenST, returnST )
+# endif
+
 #else
 
 #define ARR_ELT 	(:=)
diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 92afb68..5c8e3f1 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -60,6 +60,14 @@ import PrelBase ( Char (..) )
 #if __GLASGOW_HASKELL__ >= 206
 import PackBase
 #endif
+#if __GLASGOW_HASKELL__ >= 209
+import Addr
+import IORef
+# define newVar   newIORef
+# define readVar  readIORef
+# define writeVar writeIORef
+#endif
+
 #endif
 
 import PrimPacked
@@ -179,26 +187,32 @@ data FastStringTable =
     Int#
     (MutableArray# _RealWorld [FastString])
 
+#if __GLASGOW_HASKELL__ < 209
 type FastStringTableVar = MutableVar _RealWorld FastStringTable
+#else
+type FastStringTableVar = IORef FastStringTable
+#endif
 
 string_table :: FastStringTableVar
 string_table = 
  unsafePerformPrimIO (
-   newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
+   ST_TO_PrimIO (newArray (0::Int,hASH_TBL_SIZE) []) `thenPrimIO` \ (_MutableArray _ arr#) ->
    newVar (FastStringTable 0# arr#))
 
 lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
-  MkST ( \ (S# s#) ->
+  ST_TO_PrimIO (
+  MkST ( \ STATE_TOK(s#) ->
   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
-    (r, S# s2#) })
+    ST_RET(r, STATE_TOK(s2#)) }))
 
 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
-updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls =
- MkST ( \ (S# s#) ->
+updTbl ref (FastStringTable uid# arr#) i# ls =
+ ST_TO_PrimIO (
+ MkST ( \ STATE_TOK(s#) ->
  case writeArray# arr# i# ls s# of { s2# ->
- case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
-  ((), S# s3#) }})
+  ST_RET((), STATE_TOK(s2#)) })) `thenPrimIO` \ _ ->
+ writeVar ref (FastStringTable (uid# +# 1#) arr#)
 
 mkFastString# :: Addr# -> Int# -> FastString
 mkFastString# a# len# =
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index d72dc85..ea11887 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -35,6 +35,10 @@ module Outputable (
 #if __GLASGOW_HASKELL__ >= 202
 import IO
 import GlaExts
+# if __GLASGOW_HASKELL__ >= 209
+import Addr
+# endif
+
 #else
 import Ubiq		( Uniquable(..), Unique, Name )	-- FastString mentions it; todo: rm
 
diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs
index 6c19894..78f0071 100644
--- a/ghc/compiler/utils/PrimPacked.lhs
+++ b/ghc/compiler/utils/PrimPacked.lhs
@@ -52,6 +52,10 @@ import PrelBase ( Char(..) )
 import PackBase
 # endif
 
+# if __GLASGOW_HASKELL__ >= 209
+import Addr
+# endif
+
 #endif
 
 \end{code} 
@@ -73,21 +77,19 @@ Copying a char string prefix into a byte array,
 NULs.
 
 \begin{code}
+
 copyPrefixStr :: _Addr -> Int -> _ByteArray Int
 copyPrefixStr (A# a) len@(I# length#) =
- unsafePerformPrimIO (
+ unsafePerformST (
   {- allocate an array that will hold the string
     (not forgetting the NUL at the end)
   -}
-  (new_ps_array (length# +# 1#))             `thenPrimIO` \ ch_array ->
-{- Revert back to Haskell-only solution for the moment.
-   _ccall_ memcpy ch_array (A# a) len        `thenPrimIO`  \ () ->
-   write_ps_array ch_array length# (chr# 0#) `seqPrimIO`
--}
+  new_ps_array (length# +# 1#)               `thenStrictlyST` \ ch_array ->
    -- fill in packed string from "addr"
-  fill_in ch_array 0#			     `seqPrimIO`
+  fill_in ch_array 0#			     `thenStrictlyST` \ _ ->
    -- freeze the puppy:
-  freeze_ps_array ch_array)
+  freeze_ps_array ch_array		     `thenStrictlyST` \ barr ->
+  returnStrictlyST barr )
   where
     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
 
@@ -119,7 +121,7 @@ Copying a sub-string out of a ForeignObj
 \begin{code}
 copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int
 copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
- unsafePerformPrimIO (
+ unsafePerformST (
   {- allocate an array that will hold the string
     (not forgetting the NUL at the end)
   -}
@@ -159,7 +161,7 @@ addrOffset# a# i# =
 
 copySubStrBA :: _ByteArray Int -> Int -> Int -> _ByteArray Int
 copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) =
- unsafePerformPrimIO (
+ unsafePerformST (
   {- allocate an array that will hold the string
     (not forgetting the NUL at the end)
   -}
@@ -190,20 +192,20 @@ write_ps_array	:: _MutableByteArray s Int -> Int# -> Char# -> _ST s ()
 freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
 
 new_ps_array size =
-    MkST ( \ (S# s) ->
-    case (newCharArray# size s)	  of { StateAndMutableByteArray# s2# barr# ->
-    (_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, S# s2#)})
+    MkST ( \ STATE_TOK(s#) ->
+    case (newCharArray# size s#)  of { StateAndMutableByteArray# s2# barr# ->
+    ST_RET(_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, STATE_TOK(s2#))})
 
 write_ps_array (_MutableByteArray _ barr#) n ch =
-    MkST ( \ (S# s#) ->
+    MkST ( \ STATE_TOK(s#) ->
     case writeCharArray# barr# n ch s#	of { s2#   ->
-    ((), S# s2#)})
+    ST_RET((), STATE_TOK(s2#) )})
 
 -- same as unsafeFreezeByteArray
 freeze_ps_array (_MutableByteArray ixs arr#) =
-    MkST ( \ (S# s#) ->
+    MkST ( \ STATE_TOK(s#) ->
     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
-    (_ByteArray ixs frozen#, S# s2#) })
+    ST_RET((_ByteArray ixs frozen#), STATE_TOK(s2#))})
 \end{code}
 
 Compare two equal-length strings for equality:
diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs
index d436384..1103750 100644
--- a/ghc/compiler/utils/SST.lhs
+++ b/ghc/compiler/utils/SST.lhs
@@ -47,7 +47,7 @@ type SST s r = State# s -> SST_R s r
 sstToST :: SST s r -> ST s r
 stToSST :: ST s r -> SST s r
 
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ >= 200 && __GLASGOW_HASKELL__ < 209
 
 sstToST sst = ST $ \ (S# s) ->
    case sst s of SST_R r s' -> (r, S# s')
@@ -55,6 +55,14 @@ sstToST sst = ST $ \ (S# s) ->
 stToSST (ST st) = \ s ->
    case st (S# s) of (r, S# s') -> SST_R r s'
 
+#elif __GLASGOW_HASKELL__ >= 209
+
+sstToST sst = ST $ \ s ->
+   case sst s of SST_R r s' -> STret s' r
+
+stToSST (ST st) = \ s ->
+   case st s of STret s' r -> SST_R r s'
+
 #else
 sstToST sst (S# s)
   = case sst s of SST_R r s' -> (r, S# s')
diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index c12aa2d..5c070da 100644
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -78,6 +78,9 @@ import PrelBase ( Char(..) )
 # if __GLASGOW_HASKELL__ >= 206
 import PackBase 
 # endif
+# if __GLASGOW_HASKELL__ >= 209
+import Addr
+# endif
 #endif
 import PrimPacked
 import FastString
-- 
1.7.10.4