From: andy <unknown>
Date: Mon, 6 Mar 2000 08:42:56 +0000 (+0000)
Subject: [project @ 2000-03-06 08:42:56 by andy]
X-Git-Tag: Approximately_9120_patches~5059
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a2f35a4647114bf93c2149925a6fa3bd87683452;p=ghc-hetmet.git

[project @ 2000-03-06 08:42:56 by andy]
Adding prelude changes require for the new libs, include IOExts.
Reintroducing ptr equality into HugsSTG.
---

diff --git a/ghc/includes/options.h b/ghc/includes/options.h
index dc826a2..5ed6c4e 100644
--- a/ghc/includes/options.h
+++ b/ghc/includes/options.h
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: options.h,v $
- * $Revision: 1.17 $
- * $Date: 2000/02/25 10:53:53 $
+ * $Revision: 1.18 $
+ * $Date: 2000/03/06 08:42:56 $
  * ------------------------------------------------------------------------*/
 
 
@@ -172,6 +172,7 @@
 #undef  PROVIDE_PTREQUALITY
 #undef  PROVIDE_COERCE
 
+#define PROVIDE_PTREQUALITY 1
 
 /* Set to 1 to use a non-GMP implementation of integer, in the
    standalone Hugs.  Set to 0 in the combined GHC-Hugs system,
diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 09d1a03..cde2783 100644
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -104,14 +104,24 @@ module Prelude (
 
     , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
     , ThreadId, forkIO
-    ,trace
+    , trace
 
+
+    , ST(..)
     , STRef, newSTRef, readSTRef, writeSTRef
     , IORef, newIORef, readIORef, writeIORef
+    , PrimMutableArray, PrimMutableByteArray
+    , RealWorld
 
     -- This lot really shouldn't be exported, but are needed to
     -- implement various libs.
+    , runST , fixST, unsafeInterleaveST 
+    , stToIO , ioToST
+    , unsafePerformIO
+    , primReallyUnsafePtrEquality
     ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
+    ,primReadArray, primIndexArray, primSizeMutableArray
+    ,primSizeArray
     ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
     ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
     ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
@@ -1801,7 +1811,7 @@ primGetEnv v
      nh_getenv ptr                >>= \ptr2 ->
      nh_free ptr                  >>
      if   isNullAddr ptr2
-     then return []
+     then ioError (IOError "getEnv failed")
      else
      copy_cstring_to_String ptr2  >>= \result ->
      return result
@@ -1813,18 +1823,40 @@ primGetEnv v
 
 newtype ST s a = ST (s -> (a,s))
 
-data RealWorld
-type IO a = ST RealWorld a
-
---primRunST :: (forall s. ST s a) -> a
 primRunST :: ST RealWorld a -> a
 primRunST m = fst (unST m theWorld)
    where
       theWorld :: RealWorld
       theWorld = error "primRunST: entered the RealWorld"
 
+runST :: (__forall s . ST s a) -> a
+runST m = fst (unST m alpha)
+   where
+      alpha = error "primRunST: entered the RealWorld"
+
+fixST :: (a -> ST s a) -> ST s a
+fixST m = ST (\ s -> 
+		let 
+		   (r,s) = unST (m r) s
+		in
+		   (r,s))
+
 unST (ST a) = a
 
+data RealWorld
+-- Should IO not be abstract? 
+-- Is "instance (IO a)" allowed, for example ?
+type IO a = ST RealWorld a
+
+stToIO	      :: ST RealWorld a -> IO a
+stToIO = id
+
+ioToST	      :: IO a -> ST RealWorld a
+ioToST = id
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = primRunST (ioToST m)
+
 instance Functor (ST s) where
    fmap f x  = x >>= (return . f)
 
diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 09d1a03..cde2783 100644
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -104,14 +104,24 @@ module Prelude (
 
     , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
     , ThreadId, forkIO
-    ,trace
+    , trace
 
+
+    , ST(..)
     , STRef, newSTRef, readSTRef, writeSTRef
     , IORef, newIORef, readIORef, writeIORef
+    , PrimMutableArray, PrimMutableByteArray
+    , RealWorld
 
     -- This lot really shouldn't be exported, but are needed to
     -- implement various libs.
+    , runST , fixST, unsafeInterleaveST 
+    , stToIO , ioToST
+    , unsafePerformIO
+    , primReallyUnsafePtrEquality
     ,hugsprimCompAux,PrimArray,primRunST,primNewArray,primWriteArray
+    ,primReadArray, primIndexArray, primSizeMutableArray
+    ,primSizeArray
     ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv
     ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open
     ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar
@@ -1801,7 +1811,7 @@ primGetEnv v
      nh_getenv ptr                >>= \ptr2 ->
      nh_free ptr                  >>
      if   isNullAddr ptr2
-     then return []
+     then ioError (IOError "getEnv failed")
      else
      copy_cstring_to_String ptr2  >>= \result ->
      return result
@@ -1813,18 +1823,40 @@ primGetEnv v
 
 newtype ST s a = ST (s -> (a,s))
 
-data RealWorld
-type IO a = ST RealWorld a
-
---primRunST :: (forall s. ST s a) -> a
 primRunST :: ST RealWorld a -> a
 primRunST m = fst (unST m theWorld)
    where
       theWorld :: RealWorld
       theWorld = error "primRunST: entered the RealWorld"
 
+runST :: (__forall s . ST s a) -> a
+runST m = fst (unST m alpha)
+   where
+      alpha = error "primRunST: entered the RealWorld"
+
+fixST :: (a -> ST s a) -> ST s a
+fixST m = ST (\ s -> 
+		let 
+		   (r,s) = unST (m r) s
+		in
+		   (r,s))
+
 unST (ST a) = a
 
+data RealWorld
+-- Should IO not be abstract? 
+-- Is "instance (IO a)" allowed, for example ?
+type IO a = ST RealWorld a
+
+stToIO	      :: ST RealWorld a -> IO a
+stToIO = id
+
+ioToST	      :: IO a -> ST RealWorld a
+ioToST = id
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = primRunST (ioToST m)
+
 instance Functor (ST s) where
    fmap f x  = x >>= (return . f)