From 1e1907fb42b74de4feb5ac8af10846db31e56edb Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 2 Jan 2002 14:40:11 +0000 Subject: [PATCH] [project @ 2002-01-02 14:40:09 by simonmar] Make this compile again, and update with latest changes from hslibs/lang. --- Control/Monad/ST/Lazy.hs | 148 +--------------------------------------------- Data/Array/Base.hs | 99 +++++++++++++------------------ Data/Array/Diff.hs | 49 ++++++++++++++- Data/Array/IO.hs | 34 +++++------ Data/IORef.hs | 21 ++++--- GHC/Exts.hs | 37 ++++++++++++ GHC/Handle.hs | 24 ++++---- GHC/IO.hs | 43 ++++++-------- GHC/Posix.hsc | 4 +- Numeric.hs | 6 +- System/Environment.hs | 3 +- cbits/PrelIOUtils.c | 2 +- cbits/writeError.c | 4 +- include/HsCore.h | 7 ++- include/PrelIOUtils.h | 40 ------------- include/dirUtils.h | 6 +- 16 files changed, 199 insertions(+), 328 deletions(-) create mode 100644 GHC/Exts.hs delete mode 100644 include/PrelIOUtils.h diff --git a/Control/Monad/ST/Lazy.hs b/Control/Monad/ST/Lazy.hs index 5d3c557..bb56e28 100644 --- 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 --- 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 --- 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 --- 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 --- 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 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 + #ifdef HAVE_SYS_TYPES_H #include #endif @@ -91,7 +93,6 @@ #include "lockFile.h" #include "dirUtils.h" #include "errUtils.h" -#include "PrelIOUtils.h" #ifdef _WIN32 #include @@ -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 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 --- a/include/dirUtils.h +++ b/include/dirUtils.h @@ -6,11 +6,9 @@ #ifndef __DIRUTILS_H__ #define __DIRUTILS_H__ -#include -#include +#include "HsCore.h" + #include -#include -#include extern HsInt prel_mkdir(HsAddr pathName, HsInt mode); extern HsInt prel_lstat(HsAddr fname, HsAddr st); -- 1.7.10.4