[project @ 2002-01-02 14:40:09 by simonmar]

Make this compile again, and update with latest changes from hslibs/lang.

diff --git a/Control/Monad/ST/Lazy.hs b/Control/Monad/ST/Lazy.hs
index 5d3c557..bb56e28 100644 (file)
--- a/Control/Monad/ST/Lazy.hs
+++ b/Control/Monad/ST/Lazy.hs
@@ -8,7 +8,7 @@
 -- Stability   :  provisional
 -- Portability :  non-portable (requires universal quantification for runST)
 --
--- $Id: Lazy.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $
+-- $Id: Lazy.hs,v 1.4 2002/01/02 14:40:09 simonmar Exp $
 --
 -- This module presents an identical interface to Control.Monad.ST,
 -- but the underlying implementation of the state thread is lazy.
@@ -22,17 +22,6 @@ module Control.Monad.ST.Lazy (
        unsafeInterleaveST,
        fixST,
 
-       STRef.STRef,
-       newSTRef, readSTRef, writeSTRef,
-
-       STArray.STArray,
-       newSTArray, readSTArray, writeSTArray, boundsSTArray, 
-       thawSTArray, freezeSTArray, unsafeFreezeSTArray, 
-#ifdef __GLASGOW_HASKELL__
--- no 'good' reason, just doesn't support it right now.
-        unsafeThawSTArray,
-#endif
-
        ST.unsafeIOToST, ST.stToIO,
 
        strictToLazyST, lazyToStrictST
@@ -40,47 +29,18 @@ module Control.Monad.ST.Lazy (
 
 import Prelude
 
-import qualified Data.STRef as STRef
-import Data.Array
-
 #ifdef __GLASGOW_HASKELL__
 import qualified Control.Monad.ST as ST
-import qualified GHC.Arr as STArray
 import qualified GHC.ST
 import GHC.Base
 import Control.Monad
-import Data.Ix
 #endif
 
-#ifdef __HUGS__
-import qualified ST
-import Monad
-import Ix
-import Array
-import PrelPrim ( unST 
-                , mkST 
-                , PrimMutableArray
-                , PrimArray
-                , primNewArray
-                , primReadArray
-                , primWriteArray
-                , primUnsafeFreezeArray
-                , primSizeMutableArray
-                , primSizeArray
-                , primIndexArray
-                )
-#endif
-
-
 #ifdef __GLASGOW_HASKELL__
 newtype ST s a = ST (State s -> (a, State s))
 data State s = S# (State# s)
 #endif
 
-#ifdef __HUGS__
-newtype ST s a = ST (s -> (a,s))
-#endif
-
 instance Functor (ST s) where
     fmap f m = ST $ \ s ->
       let 
@@ -108,13 +68,6 @@ instance Monad (ST s) where
 {-# NOINLINE runST #-}
 runST :: (forall s. ST s a) -> a
 runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
-#endif
-
-#ifdef __HUGS__
-runST :: (__forall s. ST s a) -> a
-runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
-       where realWorld = error "runST: entered the RealWorld"
-#endif
 
 fixST :: (a -> ST s a) -> ST s a
 fixST m = ST (\ s -> 
@@ -123,90 +76,6 @@ fixST m = ST (\ s ->
                   (r,s)  = m_r s
                in
                   (r,s))
-
--- ---------------------------------------------------------------------------
--- Variables
-
-newSTRef   :: a -> ST s (STRef.STRef s a)
-readSTRef  :: STRef.STRef s a -> ST s a
-writeSTRef :: STRef.STRef s a -> a -> ST s ()
-
-newSTRef   = strictToLazyST . STRef.newSTRef
-readSTRef  = strictToLazyST . STRef.readSTRef
-writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
-
--- --------------------------------------------------------------------------
--- Arrays
-
-newSTArray         :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
-readSTArray        :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt 
-writeSTArray       :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s () 
-boundsSTArray       :: Ix ix => STArray.STArray s ix elt -> (ix, ix)  
-thawSTArray        :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
-freezeSTArray      :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
-unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
-
-#ifdef __GLASGOW_HASKELL__
-
-newSTArray ixs init    = strictToLazyST (STArray.newSTArray ixs init)
-
-readSTArray arr ix      = strictToLazyST (STArray.readSTArray arr ix)
-writeSTArray arr ix v   = strictToLazyST (STArray.writeSTArray arr ix v)
-boundsSTArray arr       = STArray.boundsSTArray arr
-thawSTArray arr                = strictToLazyST (STArray.thawSTArray arr)
-freezeSTArray arr       = strictToLazyST (STArray.freezeSTArray arr)
-unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
-unsafeThawSTArray arr   = strictToLazyST (STArray.unsafeThawSTArray arr)
-#endif
-
-
-#ifdef __HUGS__
-newSTArray ixs elt = do
-  { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
-  ; return (STArray ixs arr)
-  }
-
-boundsSTArray (STArray ixs arr)        = ixs
-readSTArray   (STArray ixs arr) ix     
-       = strictToLazyST (primReadArray arr (index ixs ix))
-writeSTArray  (STArray ixs arr) ix elt 
-       = strictToLazyST (primWriteArray arr (index ixs ix) elt)
-freezeSTArray (STArray ixs arr)        = do
-  { arr' <- strictToLazyST (primFreezeArray arr)
-  ; return (Array ixs arr')
-  }
-
-unsafeFreezeSTArray (STArray ixs arr)  = do 
-  { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
-  ; return (Array ixs arr')
-  }
-
-thawSTArray (Array ixs arr) = do
-  { arr' <- strictToLazyST (primThawArray arr)
-  ; return (STArray ixs arr')
-  }
-
-primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
-primFreezeArray arr = do
-  { let n = primSizeMutableArray arr
-  ; arr' <- primNewArray n arrEleBottom
-  ; mapM_ (copy arr arr') [0..n-1]
-  ; primUnsafeFreezeArray arr'
-  }
- where
-  copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
-  arrEleBottom = error "primFreezeArray: panic"
-
-primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
-primThawArray arr = do
-  { let n = primSizeArray arr
-  ; arr' <- primNewArray n arrEleBottom
-  ; mapM_ (copy arr arr') [0..n-1]
-  ; return arr'
-  }
- where
-  copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
-  arrEleBottom = error "primFreezeArray: panic"
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -227,20 +96,5 @@ lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
         case (m (S# s)) of (a, S# s') -> (# s', a #)
 #endif
 
-#ifdef __HUGS__
-strictToLazyST :: ST.ST s a -> ST s a
-strictToLazyST m = ST $ \s ->
-        let 
-          pr = unST m s
-          r  = fst pr
-          s' = snd pr
-       in
-       (r, s')
-
-
-lazyToStrictST :: ST s a -> ST.ST s a
-lazyToStrictST (ST m) = mkST $ m
-#endif
-
 unsafeInterleaveST :: ST s a -> ST s a
 unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST

diff --git a/Data/Array/Base.hs b/Data/Array/Base.hs
index 2d7cdca..711b55a 100644 (file)
--- a/Data/Array/Base.hs
+++ b/Data/Array/Base.hs
@@ -9,7 +9,7 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- $Id: Base.hs,v 1.4 2001/07/31 14:36:19 simonmar Exp $
+-- $Id: Base.hs,v 1.5 2002/01/02 14:40:10 simonmar Exp $
 --
 -- Basis for IArray and MArray.  Not intended for external consumption;
 -- use IArray or MArray instead.
@@ -319,9 +319,16 @@ cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
 
 {-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-}
 
-showsUArray :: (IArray UArray e, Ix i, Show i, Show e)
-            => Int -> UArray i e -> ShowS
-showsUArray p a =
+-----------------------------------------------------------------------------
+-- Showing IArrays
+
+{-# SPECIALISE 
+    showsIArray :: (IArray UArray e, Ix i, Show i, Show e) => 
+                  Int -> UArray i e -> ShowS
+  #-}
+
+showsIArray :: (IArray a e, Ix i, Show i, Show e) => Int -> a i e -> ShowS
+showsIArray p a =
     showParen (p > 9) $
     showString "array " .
     shows (bounds a) .
@@ -481,12 +488,7 @@ instance IArray UArray Int64 where
     {-# INLINE unsafeArray #-}
     unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
     {-# INLINE unsafeAt #-}
-    unsafeAt (UArray _ _ arr#) (I# i#) =
-#if WORD_SIZE_IN_BYTES == 4
-        I64# (indexInt64Array# arr# i#)
-#else
-        I64# (indexIntArray# arr# i#)
-#endif
+    unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#)
     {-# INLINE unsafeReplace #-}
     unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
     {-# INLINE unsafeAccum #-}
@@ -534,12 +536,7 @@ instance IArray UArray Word64 where
     {-# INLINE unsafeArray #-}
     unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
     {-# INLINE unsafeAt #-}
-    unsafeAt (UArray _ _ arr#) (I# i#) =
-#if WORD_SIZE_IN_BYTES == 4
-        W64# (indexWord64Array# arr# i#)
-#else
-        W64# (indexWordArray# arr# i#)
-#endif
+    unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#)
     {-# INLINE unsafeReplace #-}
     unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
     {-# INLINE unsafeAccum #-}
@@ -647,46 +644,46 @@ instance Ix ix => Ord (UArray ix Word64) where
     compare = cmpUArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Bool) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Char) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Int) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Word) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Float) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Double) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Int8) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Int16) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Int32) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Int64) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Word8) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Word16) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Word32) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 instance (Ix ix, Show ix) => Show (UArray ix Word64) where
-    showsPrec = showsUArray
+    showsPrec = showsIArray
 
 -----------------------------------------------------------------------------
 -- Mutable arrays
@@ -1016,20 +1013,12 @@ instance MArray (STUArray s) Int64 (ST s) where
         case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
         (# s2#, STUArray l u marr# #) }}
     {-# INLINE unsafeRead #-}
-    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
-#if WORD_SIZE_IN_BYTES == 4
+    unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> 
         case readInt64Array# marr# i# s1# of { (# s2#, e# #) ->
-#else
-        case readIntArray# marr# i# s1# of { (# s2#, e# #) ->
-#endif
         (# s2#, I64# e# #) }
     {-# INLINE unsafeWrite #-}
     unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# ->
-#if WORD_SIZE_IN_BYTES == 4
         case writeInt64Array# marr# i# e# s1# of { s2# ->
-#else
-        case writeIntArray# marr# i# e# s1# of { s2# ->
-#endif
         (# s2#, () #) }
 
 instance MArray (STUArray s) Word8 (ST s) where
@@ -1085,19 +1074,11 @@ instance MArray (STUArray s) Word64 (ST s) where
         (# s2#, STUArray l u marr# #) }}
     {-# INLINE unsafeRead #-}
     unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
-#if WORD_SIZE_IN_BYTES == 4
         case readWord64Array# marr# i# s1# of { (# s2#, e# #) ->
-#else
-        case readWordArray# marr# i# s1# of { (# s2#, e# #) ->
-#endif
         (# s2#, W64# e# #) }
     {-# INLINE unsafeWrite #-}
     unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# ->
-#if WORD_SIZE_IN_BYTES == 4
         case writeWord64Array# marr# i# e# s1# of { s2# ->
-#else
-        case writeWordArray# marr# i# e# s1# of { s2# ->
-#endif
         (# s2#, () #) }
 
 -----------------------------------------------------------------------------
@@ -1105,24 +1086,24 @@ instance MArray (STUArray s) Word64 (ST s) where
 
 bOOL_SCALE, bOOL_WORD_SCALE,
   wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int#
-bOOL_SCALE n# = (n# +# last#) `iShiftRA#` 3#
-  where I# last# = WORD_SIZE_IN_BYTES * 8 - 1
+bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3#
+  where I# last# = SIZEOF_HSWORD * 8 - 1
 bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#)
-  where I# last# = WORD_SIZE_IN_BYTES * 8 - 1
-wORD_SCALE   n# = scale# *# n# where I# scale# = WORD_SIZE_IN_BYTES
-dOUBLE_SCALE n# = scale# *# n# where I# scale# = DOUBLE_SIZE_IN_BYTES
-fLOAT_SCALE  n# = scale# *# n# where I# scale# = FLOAT_SIZE_IN_BYTES
+  where I# last# = SIZEOF_HSWORD * 8 - 1
+wORD_SCALE   n# = scale# *# n# where I# scale# = SIZEOF_HSWORD
+dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_HSDOUBLE
+fLOAT_SCALE  n# = scale# *# n# where I# scale# = SIZEOF_HSFLOAT
 
 bOOL_INDEX :: Int# -> Int#
-#if WORD_SIZE_IN_BYTES == 4
-bOOL_INDEX i# = i# `iShiftRA#` 5#
-#elif WORD_SIZE_IN_BYTES == 8
-bOOL_INDEX i# = i# `iShiftRA#` 6#
+#if SIZEOF_HSWORD == 4
+bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5#
+#elif SIZEOF_HSWORD == 8
+bOOL_INDEX i# = i# `uncheckedIShiftRA#` 6#
 #endif
 
 bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word#
-bOOL_BIT     n# = int2Word# 1# `shiftL#` (word2Int# (int2Word# n# `and#` mask#))
-  where W# mask# = WORD_SIZE_IN_BYTES * 8 - 1
+bOOL_BIT     n# = int2Word# 1# `uncheckedShiftL#` (word2Int# (int2Word# n# `and#` mask#))
+  where W# mask# = SIZEOF_HSWORD * 8 - 1
 bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound
 
 -----------------------------------------------------------------------------

diff --git a/Data/Array/Diff.hs b/Data/Array/Diff.hs
index 2ef109f..a0ff54e 100644 (file)
--- a/Data/Array/Diff.hs
+++ b/Data/Array/Diff.hs
@@ -8,7 +8,7 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- $Id: Diff.hs,v 1.1 2001/07/04 10:48:39 simonmar Exp $
+-- $Id: Diff.hs,v 1.2 2002/01/02 14:40:10 simonmar Exp $
 --
 -- Functional arrays with constant-time update.
 --
@@ -104,6 +104,51 @@ type DiffUArray = IOToDiffArray IOUArray
 -- -fallow-undecidable-instances, so each instance is separate here.
 
 ------------------------------------------------------------------------
+-- Showing DiffArrays
+
+instance (Ix ix, Show ix, Show e) => Show (DiffArray ix e) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Char) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Int) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Word) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Float) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Double) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Int8) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Int16) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Int32) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Int64) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Word8) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Word16) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Word32) where
+  showsPrec = showsIArray
+
+instance (Ix ix, Show ix) => Show (DiffUArray ix Word64) where
+  showsPrec = showsIArray
+
+------------------------------------------------------------------------
 -- Boring instances.
 
 instance HasBounds a => HasBounds (IOToDiffArray a) where
@@ -194,6 +239,8 @@ instance IArray (IOToDiffArray IOUArray) Word64 where
     unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i
     unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray` ies
 
+
+
 ------------------------------------------------------------------------
 -- The important stuff.
 

diff --git a/Data/Array/IO.hs b/Data/Array/IO.hs
index c9eef9f..f4faa52 100644 (file)
--- a/Data/Array/IO.hs
+++ b/Data/Array/IO.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -#include "HsCore.h" #-}
 -----------------------------------------------------------------------------
 -- 
 -- Module      :  Data.Array.IO
@@ -8,7 +9,7 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- $Id: IO.hs,v 1.2 2001/09/14 11:25:23 simonmar Exp $
+-- $Id: IO.hs,v 1.3 2002/01/02 14:40:10 simonmar Exp $
 --
 -- Mutable boxed/unboxed arrays in the IO monad.
 --
@@ -377,10 +378,10 @@ hGetArray handle (IOUArray (STUArray l u ptr)) count
   = illegalBufferSize handle "hGetArray" count
   | otherwise = do
       wantReadableHandle "hGetArray" handle $ 
-       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
        buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
        if bufferEmpty buf
-          then readChunkBA fd ptr 0 count
+          then readChunk fd is_stream ptr 0 count
           else do 
                let avail = w - r
                copied <- if (count >= avail)
@@ -395,18 +396,18 @@ hGetArray handle (IOUArray (STUArray l u ptr)) count
 
                let remaining = count - copied
                if remaining > 0 
-                  then do rest <- readChunkBA fd ptr copied remaining
+                  then do rest <- readChunk fd is_stream ptr copied remaining
                           return (rest + count)
                   else return count
-               
-readChunkBA :: FD -> RawBuffer -> Int -> Int -> IO Int
-readChunkBA fd ptr init_off bytes = loop init_off bytes 
+
+readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
+readChunk fd is_stream ptr init_off bytes = loop init_off bytes 
  where
   loop :: Int -> Int -> IO Int
   loop off bytes | bytes <= 0 = return (off - init_off)
   loop off bytes = do
     r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
-           (readBA (fromIntegral fd) ptr 
+           (read_off (fromIntegral fd) is_stream ptr 
                (fromIntegral off) (fromIntegral bytes))
            (threadWaitRead fd)
     let r = fromIntegral r'
@@ -414,10 +415,7 @@ readChunkBA fd ptr init_off bytes = loop init_off bytes
        then return (off - init_off)
        else loop (off + r) (bytes - r)
 
-foreign import "read_ba_wrap" unsafe
-   readBA :: FD -> RawBuffer -> Int -> CInt -> IO CInt
-
- -----------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
 -- hPutArray
 
 hPutArray
@@ -431,7 +429,7 @@ hPutArray handle (IOUArray (STUArray l u raw)) count
   = illegalBufferSize handle "hPutArray" count
   | otherwise
    = do wantWritableHandle "hPutArray" handle $ 
-          \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+          \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
 
           old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
            <- readIORef ref
@@ -445,20 +443,20 @@ hPutArray handle (IOUArray (STUArray l u raw)) count
                    return ()
 
                -- else, we have to flush
-           else do flushed_buf <- flushWriteBuffer fd old_buf
+           else do flushed_buf <- flushWriteBuffer fd stream old_buf
                    writeIORef ref flushed_buf
                    let this_buf = 
                            Buffer{ bufBuf=raw, bufState=WriteBuffer, 
                                    bufRPtr=0, bufWPtr=count, bufSize=count }
-                   flushWriteBuffer fd this_buf
+                   flushWriteBuffer fd stream this_buf
                    return ()
 
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
 -- Internal Utils
 
-foreign import "memcpy_wrap_dst_off" unsafe 
+foreign import "__hscore_memcpy_dst_off" unsafe 
    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import "memcpy_wrap_src_off" unsafe 
+foreign import "__hscore_memcpy_src_off" unsafe 
    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
 
 illegalBufferSize :: Handle -> String -> Int -> IO a

diff --git a/Data/IORef.hs b/Data/IORef.hs
index 910ea86..8d5ef77 100644 (file)
--- a/Data/IORef.hs
+++ b/Data/IORef.hs
@@ -8,7 +8,7 @@
 -- Stability   :  experimental
 -- Portability :  portable
 --
--- $Id: IORef.hs,v 1.3 2001/12/21 15:07:21 simonmar Exp $
+-- $Id: IORef.hs,v 1.4 2002/01/02 14:40:09 simonmar Exp $
 --
 -- Mutable references in the IO monad.
 --
@@ -37,19 +37,26 @@ import GHC.Weak
 #endif
 #endif /* __GLASGOW_HASKELL__ */
 
-#ifdef __HUGS__
-import IOExts          ( IORef, newIORef, writeIORef, readIORef )
-import ST              ( stToIO, newSTRef, readSTRef, writeSTRef )
-#endif
-
 import Data.Dynamic
 
-#ifndef __PARALLEL_HASKELL__
+#if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__)
 mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
 mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->
   case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
 #endif
 
+#if defined __HUGS__
+data IORef a        -- mutable variables containing values of type a
+
+primitive newIORef   "newRef" :: a -> IO (IORef a)
+primitive readIORef  "getRef" :: IORef a -> IO a
+primitive writeIORef "setRef" :: IORef a -> a -> IO ()
+primitive eqIORef    "eqRef"  :: IORef a -> IORef a -> Bool
+
+instance Eq (IORef a) where
+    (==) = eqIORef
+#endif /* __HUGS__ */
+
 modifyIORef :: IORef a -> (a -> a) -> IO ()
 modifyIORef ref f = writeIORef ref . f =<< readIORef ref
 

diff --git a/GHC/Exts.hs b/GHC/Exts.hs
new file mode 100644 (file)
index 0000000..3ba88ca
--- /dev/null
+++ b/GHC/Exts.hs
@@ -0,0 +1,37 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  GHC.Exts
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- $Id: Exts.hs,v 1.1 2002/01/02 14:40:10 simonmar Exp $
+--
+-- GHC Extensions: this is the Approved Way to get at GHC-specific stuff.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Exts
+       (
+        -- the representation of some basic types:
+        Int(..),Word(..),Float(..),Double(..),Integer(..),Char(..),
+
+       -- Fusion
+       build, augment,
+
+       -- shifty wrappers from GHC.Base
+       shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
+
+        -- and finally, all the unboxed primops of GHC!
+        module GHC.Prim
+
+       ) where
+
+import {-# SOURCE #-} GHC.Prim
+import GHC.Base
+import GHC.Word
+import GHC.Num
+import GHC.Float

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 94b0203..1b9a92a 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -4,7 +4,7 @@
 #undef DEBUG
 
 -- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.1 2001/12/21 15:07:22 simonmar Exp $
+-- $Id: Handle.hs,v 1.2 2002/01/02 14:40:10 simonmar Exp $
 --
 -- (c) The University of Glasgow, 1994-2001
 --
@@ -333,19 +333,19 @@ newEmptyBuffer b state size
   = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
 
 allocateBuffer :: Int -> BufferState -> IO Buffer
-allocateBuffer sz@(I## size) state = IO $ \s -> 
-  case newByteArray## size s of { (## s, b ##) ->
-  (## s, newEmptyBuffer b state sz ##) }
+allocateBuffer sz@(I# size) state = IO $ \s -> 
+  case newByteArray# size s of { (# s, b #) ->
+  (# s, newEmptyBuffer b state sz #) }
 
 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
-writeCharIntoBuffer slab (I## off) (C## c)
-  = IO $ \s -> case writeCharArray## slab off c s of 
-                s -> (## s, I## (off +## 1##) ##)
+writeCharIntoBuffer slab (I# off) (C# c)
+  = IO $ \s -> case writeCharArray# slab off c s of 
+                s -> (# s, I# (off +# 1#) #)
 
 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
-readCharFromBuffer slab (I## off)
-  = IO $ \s -> case readCharArray## slab off s of 
-                (## s, c ##) -> (## s, (C## c, I## (off +## 1##)) ##)
+readCharFromBuffer slab (I# off)
+  = IO $ \s -> case readCharArray# slab off s of 
+                (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
 
 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
 getBuffer fd state = do
@@ -403,7 +403,7 @@ flushReadBuffer fd buf
      puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
 #    endif
      throwErrnoIfMinus1Retry "flushReadBuffer"
-        (c_lseek (fromIntegral fd) (fromIntegral off) sSEEK_CUR)
+        (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
      return buf{ bufWPtr=0, bufRPtr=0 }
 
 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
@@ -580,7 +580,7 @@ openFile' filepath ex_mode =
               | otherwise         = False
 
       binary_flags
-         | binary    = PrelHandle.o_BINARY
+         | binary    = GHC.Handle.o_BINARY
          | otherwise = 0
 
       oflags = oflags1 .|. binary_flags

diff --git a/GHC/IO.hs b/GHC/IO.hs
index 801e683..9a488b5 100644 (file)
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -3,22 +3,13 @@
 #undef DEBUG_DUMP
 
 -- -----------------------------------------------------------------------------
--- $Id: IO.hs,v 1.1 2001/12/21 15:07:23 simonmar Exp $
+-- $Id: IO.hs,v 1.2 2002/01/02 14:40:10 simonmar Exp $
 --
 -- (c) The University of Glasgow, 1992-2001
 --
--- Module GHC.IO
-
--- This module defines all basic IO operations.
--- These are needed for the IO operations exported by Prelude,
--- but as it happens they also do everything required by library
--- module IO.
 
 module GHC.IO ( 
-   putChar, putStr, putStrLn, print, getChar, getLine, getContents,
-   interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
-   hPutStrLn, hPrint,
    commitBuffer',      -- hack, see below
    hGetcBuffered,      -- needed by ghc/compiler/utils/StringBuffer.lhs
    hGetBuf, hPutBuf, slurpFile
@@ -55,7 +46,7 @@ import GHC.Conc
 
 hWaitForInput :: Handle -> Int -> IO Bool
 hWaitForInput h msecs = do
-  wantReadableHandle "hReady" h $ \ handle_ -> do
+  wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
   let ref = haBuffer handle_
   buf <- readIORef ref
 
@@ -63,7 +54,7 @@ hWaitForInput h msecs = do
        then return True
        else do
 
-  r <- throwErrnoIfMinus1Retry "hReady"
+  r <- throwErrnoIfMinus1Retry "hWaitForInput"
          (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
   return (r /= 0)
 
@@ -195,13 +186,13 @@ maybeFillReadBuffer fd is_line is_stream buf
 
 unpack :: RawBuffer -> Int -> Int -> IO [Char]
 unpack buf r 0   = return ""
-unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
+unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
    where
     unpack acc i s
-     | i <## r  = (## s, acc ##)
+     | i <# r  = (# s, acc #)
      | otherwise = 
-          case readCharArray## buf i s of
-           (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+          case readCharArray# buf i s of
+           (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 
 
 hGetLineUnBuffered :: Handle -> IO String
@@ -313,13 +304,13 @@ lazyReadHaveBuffer h handle_ fd ref buf = do
 
 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
 unpackAcc buf r 0 acc  = return ""
-unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
+unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
    where
     unpack acc i s
-     | i <## r  = (## s, acc ##)
+     | i <# r  = (# s, acc #)
      | otherwise = 
-          case readCharArray## buf i s of
-           (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+          case readCharArray# buf i s of
+           (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 
 -- ---------------------------------------------------------------------------
 -- hPutChar
@@ -429,7 +420,7 @@ writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
        return ()
    shoveString n (c:cs) = do
        n' <- writeCharIntoBuffer raw n c
-      if (c == '\n') 
+        if (c == '\n') 
          then do 
               new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
               writeLines hdl new_buf cs
@@ -484,7 +475,7 @@ commitBuffer
        -> Bool                         -- release the buffer?
        -> IO Buffer
 
-commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
+commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
   wantWritableHandle "commitAndReleaseBuffer" hdl $
      commitBuffer' hdl raw sz count flush release
 
@@ -499,7 +490,7 @@ commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
 --
 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 --
-commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
+commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 
 #ifdef DEBUG_DUMP
@@ -606,7 +597,7 @@ hPutBuf handle ptr count
   | count <= 0 = illegalBufferSize handle "hPutBuf" count
   | otherwise = 
     wantWritableHandle "hPutBuf" handle $ 
-      \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+      \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 
         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
          <- readIORef ref
@@ -620,7 +611,7 @@ hPutBuf handle ptr count
                    return ()
 
                -- else, we have to flush
-           else do flushed_buf <- flushWriteBuffer fd old_buf
+           else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
                    writeIORef ref flushed_buf
                    -- ToDo: should just memcpy instead of writing if possible
                    writeChunk fd ptr count
@@ -665,7 +656,7 @@ hGetBuf handle ptr count
                let remaining = count - copied
                if remaining > 0 
                   then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
-                          return (rest + count)
+                          return (rest + copied)
                   else return count
                
 readChunk :: FD -> Ptr a -> Int -> IO Int

diff --git a/GHC/Posix.hsc b/GHC/Posix.hsc
index 339f9bb..2d7ad08 100644 (file)
--- a/GHC/Posix.hsc
+++ b/GHC/Posix.hsc
@@ -1,7 +1,7 @@
 {-# OPTIONS -fno-implicit-prelude #-}
 
 -- ---------------------------------------------------------------------------
--- $Id: Posix.hsc,v 1.4 2001/12/21 15:07:25 simonmar Exp $
+-- $Id: Posix.hsc,v 1.5 2002/01/02 14:40:11 simonmar Exp $
 --
 -- POSIX support layer for the standard libraries
 --
@@ -224,7 +224,7 @@ setNonBlockingFD fd = do
   -- An error when setting O_NONBLOCK isn't fatal: on some systems 
   -- there are certain file handles on which this will fail (eg. /dev/null
   -- on FreeBSD) so we throw away the return code from fcntl_write.
-  fcntl_write (fromIntegral fd) 
+  c_fcntl_write (fromIntegral fd) 
        (#const F_SETFL) (flags .|. #const O_NONBLOCK)
 #else
 

diff --git a/Numeric.hs b/Numeric.hs
index 2db3d36..cef75f4 100644 (file)
--- a/Numeric.hs
+++ b/Numeric.hs
@@ -8,7 +8,7 @@
 -- Stability   :  experimental
 -- Portability :  portable
 --
--- $Id: Numeric.hs,v 1.2 2001/08/02 13:30:36 simonmar Exp $
+-- $Id: Numeric.hs,v 1.3 2002/01/02 14:40:09 simonmar Exp $
 --
 -- Odds and ends, mostly functions for reading and showing
 -- RealFloat-like kind of values.
@@ -28,11 +28,9 @@ module Numeric (
        readOct,          -- :: (Integral a) => ReadS a
        readHex,          -- :: (Integral a) => ReadS a
 
-{- -- left out for now, as we can only export the H98 interface
         showHex,          -- :: Integral a => a -> ShowS
         showOct,          -- :: Integral a => a -> ShowS
         showBin,          -- :: Integral a => a -> ShowS
--}  
       
        showEFloat,       -- :: (RealFloat a) => Maybe Int -> a -> ShowS
        showFFloat,       -- :: (RealFloat a) => Maybe Int -> a -> ShowS
@@ -44,14 +42,12 @@ module Numeric (
        floatToDigits,    -- :: (RealFloat a) => Integer -> a -> ([Int], Int)
        lexDigits,        -- :: ReadS String
 
-{- -- left out for now, as we can only export the H98 interface
           -- general purpose number->string converter.
         showIntAtBase,    -- :: Integral a 
                          -- => a               -- base
                          -- -> (a -> Char)      -- digit to char
                          -- -> a                -- number to show.
                          -- -> ShowS
--}
        ) where
 
 import Prelude         -- For dependencies

diff --git a/System/Environment.hs b/System/Environment.hs
index 6b7c570..d85a52d 100644 (file)
--- a/System/Environment.hs
+++ b/System/Environment.hs
@@ -8,7 +8,7 @@
 -- Stability   :  provisional
 -- Portability :  portable
 --
--- $Id: Environment.hs,v 1.3 2001/12/21 15:07:26 simonmar Exp $
+-- $Id: Environment.hs,v 1.4 2002/01/02 14:40:11 simonmar Exp $
 --
 -- Miscellaneous information about the system environment.
 --
@@ -25,6 +25,7 @@ import Prelude
 
 import Foreign
 import Foreign.C
+import Control.Monad
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.IOBase

diff --git a/cbits/PrelIOUtils.c b/cbits/PrelIOUtils.c
index 44065b8..f9f9e01 100644 (file)
--- a/cbits/PrelIOUtils.c
+++ b/cbits/PrelIOUtils.c
@@ -1,5 +1,5 @@
 /* 
- * (c) The University of Glasgow 2001
+ * (c) The University of Glasgow 2002
  *
  * static versions of the inline functions in HsCore.h
  */

diff --git a/cbits/writeError.c b/cbits/writeError.c
index 2ab4ce9..26ce6c2 100644 (file)
--- a/cbits/writeError.c
+++ b/cbits/writeError.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1998
  *
- * $Id: writeError.c,v 1.3 2001/12/21 15:07:26 simonmar Exp $
+ * $Id: writeError.c,v 1.4 2002/01/02 14:40:11 simonmar Exp $
  *
  * hPutStr Runtime Support
  */
@@ -20,8 +20,6 @@ implementation in one or two places.)
 #include "RtsUtils.h"
 #include "HsCore.h"
 
-#include "PrelIOUtils.h"
-
 void
 writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len)
 {

diff --git a/include/HsCore.h b/include/HsCore.h
index 3a13197..305a1ae 100644 (file)
--- a/include/HsCore.h
+++ b/include/HsCore.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: HsCore.h,v 1.5 2001/12/21 15:07:26 simonmar Exp $
+ * $Id: HsCore.h,v 1.6 2002/01/02 14:40:11 simonmar Exp $
  *
  * (c) The University of Glasgow 2001-2002
  *
@@ -13,6 +13,8 @@
 #include "config.h"
 #include "HsFFI.h"
 
+#include <stdio.h>
+
 #ifdef HAVE_SYS_TYPES_H
 #include <sys/types.h>
 #endif
@@ -91,7 +93,6 @@
 #include "lockFile.h"
 #include "dirUtils.h"
 #include "errUtils.h"
-#include "PrelIOUtils.h"
 
 #ifdef _WIN32
 #include <io.h>
@@ -128,9 +129,11 @@ INLINE int __hscore_s_ischr(m)  { return S_ISCHR(m);  }
 INLINE int __hscore_s_issock(m) { return S_ISSOCK(m); }
 #endif
 
+#ifndef mingw32_TARGET_OS
 INLINE void
 __hscore_sigemptyset( sigset_t *set )
 { sigemptyset(set); }
+#endif
 
 INLINE void *
 __hscore_memcpy_dst_off( char *dst, int dst_off, char *src, size_t sz )

diff --git a/include/PrelIOUtils.h b/include/PrelIOUtils.h
deleted file mode 100644 (file)
index d7b982f..0000000
--- a/include/PrelIOUtils.h
+++ /dev/null
@@ -1,40 +0,0 @@
-/* 
- * (c) The University of Glasgow 2001-2002
- *
- * IO / Handle support.
- */
-#ifndef __PRELIOUTILS_H__
-#define __PRELIOUTILS_H__
-
-/* PrelIOUtils.c */
-extern HsBool prel_supportsTextMode();
-extern HsInt  prel_bufsiz();
-extern HsInt prel_seek_cur();
-extern HsInt prel_seek_set();
-extern HsInt prel_seek_end();
-
-extern HsInt prel_o_binary();
-
-extern HsInt prel_setmode(HsInt fd, HsBool isBin);
-
-extern HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz);
-extern HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz);
-
-extern void* prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz);
-
-/* writeError.c */
-extern void writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len);
-
-extern int s_isreg_PrelPosix_wrap(int);
-extern int s_isdir_PrelPosix_wrap(int);
-extern int s_isfifo_PrelPosix_wrap(int);
-extern int s_isblk_PrelPosix_wrap(int);
-extern int s_ischr_PrelPosix_wrap(int);
-#ifndef mingw32_TARGET_OS
-extern int s_issock_PrelPosix_wrap(int);
-extern void sigemptyset_PrelPosix_wrap(sigset_t *set);
-#endif
-
-
-#endif /* __PRELIOUTILS_H__ */
-

diff --git a/include/dirUtils.h b/include/dirUtils.h
index 5be0657..5f52c03 100644 (file)
--- a/include/dirUtils.h
+++ b/include/dirUtils.h
@@ -6,11 +6,9 @@
 #ifndef __DIRUTILS_H__
 #define __DIRUTILS_H__
 
-#include <sys/stat.h>
-#include <dirent.h>
+#include "HsCore.h"
+
 #include <limits.h>
-#include <errno.h>
-#include <unistd.h>
 
 extern HsInt prel_mkdir(HsAddr pathName, HsInt mode);
 extern HsInt prel_lstat(HsAddr fname, HsAddr st);