diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs
index 32297e8bb98dcf3279c3297230a13747299ba417..54691bfe69eb1fe0a9ec0433bcec8056ddab1c4d 100644
--- a/ghc/lib/std/CPUTime.lhs
+++ b/ghc/lib/std/CPUTime.lhs
@@ -28,17 +28,6 @@ import IO ( ioError )
import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
import Ratio
-#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
-#define stToIO id
-#define sizeof_int64 8
-#else
-#define CCALL(fun) _ccall_ fun
-#define const_BUFSIZ ``BUFSIZ''
-#define primPackString
-#endif
-
\end{code}
Computation @getCPUTime@ returns the number of picoseconds CPU time
@@ -55,7 +44,7 @@ integral number of picoseconds.
getCPUTime :: IO Integer
getCPUTime = do
marr <- primNewByteArray (sizeof_int * 4)
- ptr <- CCALL(getCPUTime) marr
+ ptr <- getCPUTime marr
if (ptr /= nullAddr) then do
x0 <- primReadIntArray marr 0
x1 <- primReadIntArray marr 1
@@ -75,8 +64,8 @@ getCPUTime :: IO Integer
getCPUTime =
stToIO (newIntArray ((0::Int),3)) >>= \ marr ->
stToIO (unsafeFreezeByteArray marr) >>= \ barr@(ByteArray _ frozen#) ->
- _ccall_ getCPUTime barr >>= \ ptr ->
- if (ptr::Addr) /= ``NULL'' then
+ primGetCPUTime barr >>= \ ptr ->
+ if (ptr::Addr) /= nullAddr then
return ((fromIntegral (I# (indexIntArray# frozen# 0#)) * 1000000000 +
fromIntegral (I# (indexIntArray# frozen# 1#)) +
fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 +
@@ -90,17 +79,16 @@ getCPUTime =
cpuTimePrecision :: Integer
cpuTimePrecision = round ((1000000000000::Integer) %
- fromInt (unsafePerformIO (CCALL(clockTicks) )))
+ fromInt (unsafePerformIO clockTicks))
\end{code}
\begin{code}
-#ifdef __HUGS__
-
+sizeof_int :: Int
sizeof_int = 4
-foreign import stdcall "libHS_cbits.so" "getCPUTime" prim_getCPUTime :: Bytes -> IO Addr
-foreign import stdcall "libHS_cbits.so" "clockTicks" prim_clockTicks :: IO Int
-#endif
+foreign import "libHS_cbits" "getCPUTime" primGetCPUTime :: ByteArray Int -> IO Addr
+foreign import "libHS_cbits" "clockTicks" clockTicks :: IO Int
+
\end{code}
diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs
index aeb30253cb9e7fe1ff04833b508c3f939bc3e198..b4df9500fdf91efffedb0f985889cd0df8705408 100644
--- a/ghc/lib/std/IO.lhs
+++ b/ghc/lib/std/IO.lhs
@@ -127,16 +127,9 @@ import Char ( ord, chr )
#ifndef HEAD
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
#define unpackNBytesAccST primUnpackCStringAcc
-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
-#define ref_freeFileObject (``&freeFileObject''::Addr)
-#define const_BUFSIZ ``BUFSIZ''
#endif
\end{code}
@@ -193,7 +186,7 @@ hReady h = hWaitForInput h 0
hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput handle msecs =
wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do
- rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
+ rc <- inputReady (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> return False
1 -> return True
@@ -208,7 +201,7 @@ hGetChar :: Handle -> IO Char
hGetChar handle =
wantReadableHandle "hGetChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
- intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block
+ intc <- mayBlock fo (fileGetc fo) -- ConcHask: UNSAFE, may block
if intc /= ((-1)::Int)
then return (chr intc)
else constructErrorAndFail "hGetChar"
@@ -253,7 +246,7 @@ hLookAhead :: Handle -> IO Char
hLookAhead handle =
wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
let fo = haFO__ handle_
- intc <- mayBlock fo (CCALL(fileLookAhead) fo) -- ConcHask: UNSAFE, may block
+ intc <- mayBlock fo (fileLookAhead fo) -- ConcHask: UNSAFE, may block
if intc /= (-1)
then return (chr intc)
else constructErrorAndFail "hLookAhead"
@@ -322,15 +315,15 @@ lazyReadChar :: Handle -> Addr -> IO String
#endif
lazyReadBlock handle fo = do
- buf <- CCALL(getBufStart) fo (0::Int)
- bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block.
+ buf <- getBufStart fo 0
+ bytes <- mayBlock fo (readBlock fo) -- ConcHask: UNSAFE, may block.
case (bytes::Int) of
-3 -> -- buffering has been turned off, use lazyReadChar instead
lazyReadChar handle fo
-2 -> return ""
-1 -> -- an error occurred, close the handle
withHandle handle $ \ handle_ -> do
- CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flushing-} -- ConcHask: SAFE, won't block.
+ closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
return (handle_ { haType__ = ClosedHandle,
haFO__ = nullFile__ },
"")
@@ -339,24 +332,24 @@ lazyReadBlock handle fo = do
stToIO (unpackNBytesAccST buf bytes more)
lazyReadLine handle fo = do
- bytes <- mayBlock fo (CCALL(readLine) fo) -- ConcHask: UNSAFE, may block.
+ bytes <- mayBlock fo (readLine fo) -- ConcHask: UNSAFE, may block.
case (bytes::Int) of
-3 -> -- buffering has been turned off, use lazyReadChar instead
lazyReadChar handle fo
-2 -> return "" -- handle closed by someone else, stop reading.
-1 -> -- an error occurred, close the handle
withHandle handle $ \ handle_ -> do
- CCALL(closeFile) (haFO__ handle_) (0::Int){- don't bother flushing-} -- ConcHask: SAFE, won't block
+ closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
return (handle_ { haType__ = ClosedHandle,
haFO__ = nullFile__ },
"")
_ -> do
more <- unsafeInterleaveIO (lazyReadLine handle fo)
- buf <- CCALL(getBufStart) fo bytes -- ConcHask: won't block
+ buf <- getBufStart fo bytes -- ConcHask: won't block
stToIO (unpackNBytesAccST buf bytes more)
lazyReadChar handle fo = do
- char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block.
+ char <- mayBlock fo (readChar fo) -- ConcHask: UNSAFE, may block.
case (char::Int) of
-4 -> -- buffering is now block-buffered, use lazyReadBlock instead
lazyReadBlock handle fo
@@ -366,7 +359,7 @@ lazyReadChar handle fo = do
-2 -> return ""
-1 -> -- error, silently close handle.
withHandle handle $ \ handle_ -> do
- CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flusing-} -- ConcHask: SAFE, won't block
+ closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
return (handle_{ haType__ = ClosedHandle,
haFO__ = nullFile__ },
"")
@@ -393,7 +386,7 @@ hPutChar handle c =
wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
flushConnectedBuf fo
- rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
if rc == 0
then return ()
else constructErrorAndFail "hPutChar"
@@ -411,14 +404,14 @@ hPutStr handle str =
flushConnectedBuf fo
case haBufferMode__ handle_ of
LineBuffering -> do
- buf <- CCALL(getWriteableBuf) fo
- pos <- CCALL(getBufWPtr) fo
- bsz <- CCALL(getBufSize) fo
+ buf <- getWriteableBuf fo
+ pos <- getBufWPtr fo
+ bsz <- getBufSize fo
writeLines fo buf bsz pos str
BlockBuffering _ -> do
- buf <- CCALL(getWriteableBuf) fo
- pos <- CCALL(getBufWPtr) fo
- bsz <- CCALL(getBufSize) fo
+ buf <- getWriteableBuf fo
+ pos <- getBufWPtr fo
+ bsz <- getBufSize fo
writeBlocks fo buf bsz pos str
NoBuffering -> do
writeChars fo str
@@ -448,7 +441,7 @@ writeLines obj buf bufLen initPos s =
case ls of
[] ->
if n == 0 then
- CCALL(setBufWPtr) obj (0::Int)
+ setBufWPtr obj 0{-new pos-}
else do
{-
At the end of a buffer write, update the buffer position
@@ -463,14 +456,14 @@ writeLines obj buf bufLen initPos s =
that killing of threads is supported at the moment.
-}
- CCALL(setBufWPtr) obj n
+ setBufWPtr obj n
(x:xs) -> do
primWriteCharOffAddr buf n x
{- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
if n == bufLen || x == '\n'
then do
- rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (writeFileObject obj (n + 1)) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0 xs
else constructErrorAndFail "writeLines"
@@ -496,7 +489,7 @@ writeLines obj buf (I# bufLen) (I# initPos#) s =
case ls of
[] ->
if n ==# 0# then
- CCALL(setBufWPtr) obj (0::Int)
+ setBufWPtr obj 0
else do
{-
At the end of a buffer write, update the buffer position
@@ -511,14 +504,14 @@ writeLines obj buf (I# bufLen) (I# initPos#) s =
that killing of threads is supported at the moment.
-}
- CCALL(setBufWPtr) obj (I# n)
+ setBufWPtr obj (I# n)
((C# x):xs) -> do
write_char buf n x
{- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
if n ==# bufLen || x `eqChar#` '\n'#
then do
- rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0# xs
else constructErrorAndFail "writeLines"
@@ -541,7 +534,7 @@ writeBlocks obj buf bufLen initPos s =
case ls of
[] ->
if n == 0 then
- CCALL(setBufWPtr) obj (0::Int)
+ setBufWPtr obj (0::Int)
else do
{-
At the end of a buffer write, update the buffer position
@@ -558,13 +551,13 @@ writeBlocks obj buf bufLen initPos s =
alltogether.
-}
- CCALL(setBufWPtr) obj n
+ setBufWPtr obj n
(x:xs) -> do
primWriteCharOffAddr buf n x
if n == bufLen
then do
- rc <- mayBlock obj (CCALL(writeFileObject) obj (n + 1)) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (writeFileObject obj (n + 1)) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0 xs
else constructErrorAndFail "writeChunks"
@@ -590,7 +583,7 @@ writeBlocks obj buf (I# bufLen) (I# initPos#) s =
case ls of
[] ->
if n ==# 0# then
- CCALL(setBufWPtr) obj (0::Int)
+ setBufWPtr obj (0::Int)
else do
{-
At the end of a buffer write, update the buffer position
@@ -607,13 +600,13 @@ writeBlocks obj buf (I# bufLen) (I# initPos#) s =
alltogether.
-}
- CCALL(setBufWPtr) obj (I# n)
+ setBufWPtr obj (I# n)
((C# x):xs) -> do
write_char buf n x
if n ==# bufLen
then do
- rc <- mayBlock obj (CCALL(writeFileObject) obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
if rc == 0
then shoveString 0# xs
else constructErrorAndFail "writeChunks"
@@ -630,7 +623,7 @@ writeChars :: Addr -> String -> IO ()
#endif
writeChars _fo "" = return ()
writeChars fo (c:cs) = do
- rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
if rc == 0
then writeChars fo cs
else constructErrorAndFail "writeChars"
diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs
index f149108df72f811cc47e69ba38028c1f3a70e6d8..9e326cb7b37a83907a671e3750d69906b2ec1706 100644
--- a/ghc/lib/std/PrelForeign.lhs
+++ b/ghc/lib/std/PrelForeign.lhs
@@ -49,7 +49,9 @@ writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# ->
case writeForeignObj# fo# datum# s# of { s1# -> (# s1#, () #) } )
eqForeignObj mp1 mp2
- = unsafePerformIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
+ = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
+
+foreign import "eqForeignObj" primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
instance Eq ForeignObj where
p == q = eqForeignObj p q
diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index fc03be00b7742db18812c62b65e17c54da1ab589..4e60b23d8f49960103b38c5f1cd040f0ae582314 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -42,15 +42,8 @@ import PrelForeign ( makeForeignObj )
#endif /* ndef(__HUGS__) */
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
-#define sizeof_int64 8
-#else
-#define CCALL(fun) _ccall_ fun
-#define const_BUFSIZ ``BUFSIZ''
-#define primPackString
#endif
#ifndef __PARALLEL_HASKELL__
@@ -184,16 +177,11 @@ mkErrorHandle__ ioe =
%*********************************************************
\begin{code}
-#ifndef __HUGS__
-freeStdFileObject :: ForeignObj -> IO ()
-freeStdFileObject fo = CCALL(freeStdFileObject) fo
+foreign import "libHS_cbits" "freeStdFileObject"
+ freeStdFileObject :: FILE_OBJECT -> IO ()
+foreign import "libHS_cbits" "freeFileObject"
+ freeFileObject :: FILE_OBJECT -> IO ()
-freeFileObject :: ForeignObj -> IO ()
-freeFileObject fo = CCALL(freeFileObject) fo
-#else
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
-foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO ()
-#endif
\end{code}
%*********************************************************
@@ -212,19 +200,12 @@ standard error channel. These handles are initially open.
stdin, stdout, stderr :: Handle
stdout = unsafePerformIO (do
- rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block
+ rc <- getLock (1::Int) (1::Int) -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> newHandle (mkClosedHandle__)
1 -> do
-#if !defined(__CONCURRENT_HASKELL__) || defined(mingw32_TARGET_OS)
- fo <- CCALL(openStdFile) (1::Int)
- (1::Int){-flush on close-}
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-#else
- fo <- CCALL(openStdFile) (1::Int)
- ((1{-flush on close-})::Int)
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-#endif
+ fo <- openStdFile (1::Int)
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
@@ -246,19 +227,12 @@ stdout = unsafePerformIO (do
)
stdin = unsafePerformIO (do
- rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block
+ rc <- getLock (0::Int) (0::Int) -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> newHandle (mkClosedHandle__)
1 -> do
-#if !defined(__CONCURRENT_HASKELL__) || defined(mingw32_TARGET_OS)
- fo <- CCALL(openStdFile) (0::Int)
- (0::Int){-don't flush on close -}
- (1::Int){-readable-} -- ConcHask: SAFE, won't block
-#else
- fo <- CCALL(openStdFile) (0::Int)
- ((0{-flush on close-})::Int)
- (1::Int){-readable-} -- ConcHask: SAFE, won't block
-#endif
+ fo <- openStdFile (0::Int)
+ (1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
@@ -278,19 +252,12 @@ stdin = unsafePerformIO (do
stderr = unsafePerformIO (do
- rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
+ rc <- getLock (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> newHandle (mkClosedHandle__)
1 -> do
-#if !defined(__CONCURRENT_HASKELL__) || defined(mingw32_TARGET_OS)
- fo <- CCALL(openStdFile) (2::Int)
- (1::Int){-flush on close-}
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-#else
- fo <- CCALL(openStdFile) (2::Int)
- ((1{-flush on close-})::Int)
- (0::Int){-writeable-} -- ConcHask: SAFE, won't block
-#endif
+ fo <- openStdFile (2::Int)
+ (0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
@@ -329,9 +296,9 @@ openFile fp im = openFileEx fp (TextMode im)
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx f m = do
- fo <- CCALL(openFile) (primPackString f) (file_mode::Int)
- (binary::Int)
- (file_flags::Int) -- ConcHask: SAFE, won't block
+ fo <- primOpenFile (packString f)
+ (file_mode::Int)
+ (binary::Int) -- ConcHask: SAFE, won't block
if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
fo <- makeForeignObj fo
@@ -348,12 +315,12 @@ openFileEx f m = do
BinaryMode bmo -> (bmo, 1)
TextMode tmo -> (tmo, 0)
- (file_flags, file_mode) =
+ file_mode =
case imo of
- AppendMode -> (1, 0)
- WriteMode -> (1, 1)
- ReadMode -> (0, 2)
- ReadWriteMode -> (1, 3)
+ AppendMode -> 0
+ WriteMode -> 1
+ ReadMode -> 2
+ ReadWriteMode -> 3
htype = case imo of
ReadMode -> ReadHandle
@@ -395,7 +362,8 @@ hClose handle =
ErrorHandle theError -> ioError theError
ClosedHandle -> return handle_
_ -> do
- rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
+ rc <- closeFile (haFO__ handle_)
+ (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
if there were any errors. Note that after @hClose@
has been performed, the ForeignObj embedded in the Handle
@@ -436,8 +404,8 @@ hFileSize handle =
SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
_ -> do
- mem <- primNewByteArray sizeof_int64
- rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
+ mem <- primNewByteArray 8{-sizeof_int64-}
+ rc <- fileSize_int64 (haFO__ handle_) mem -- ConcHask: SAFE, won't block
if rc == 0 then do
result <- primReadInt64Array mem 0
return (primInt64ToInteger result)
@@ -449,12 +417,9 @@ hFileSize handle =
-- a single unsigned word, and we let the C routine
-- change the data bits
--
- -- For some reason, this fails to typecheck if converted to a do
- -- expression --SDM
- _casm_ ``%r = 1;'' >>= \(I# hack#) ->
- case int2Integer# hack# of
+ case int2Integer# 1# of
(# s, d #) -> do
- rc <- CCALL(fileSize) (haFO__ handle_) d -- ConcHask: SAFE, won't block
+ rc <- fileSize (haFO__ handle_) d -- ConcHask: SAFE, won't block
if rc == (0::Int) then
return (J# s d)
else
@@ -472,7 +437,7 @@ hIsEOF :: Handle -> IO Bool
hIsEOF handle =
wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (fileEOF fo) -- ConcHask: UNSAFE, may block
case rc of
0 -> return False
1 -> return True
@@ -542,7 +507,7 @@ hSetBuffering handle mode =
of semi-closed handles to change [sof 6/98]
-}
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(setBuffering) fo bsize) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (setBuffering fo bsize) -- ConcHask: UNSAFE, may block
if rc == 0
then do
return (handle_{ haBufferMode__ = mode })
@@ -567,7 +532,7 @@ hFlush :: Handle -> IO ()
hFlush handle =
wantWriteableHandle "hFlush" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(flushFile) fo) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (flushFile fo) -- ConcHask: UNSAFE, may block
if rc == 0 then
return ()
else
@@ -586,7 +551,17 @@ hFlush handle =
data HandlePosn
= HandlePosn
Handle -- Q: should this be a weak or strong ref. to the handle?
- Int
+ -- [what's the winning argument for it not being strong? --sof]
+ HandlePosition
+
+ -- HandlePosition is the Haskell equivalent of POSIX' off_t.
+ -- We represent it as an Integer on the Haskell side, but
+ -- cheat slightly in that hGetPosn calls upon a C helper
+ -- that reports the position back via (merely) an Int.
+type HandlePosition = Integer
+
+mkHandlePosn :: Handle -> HandlePosition -> HandlePosn
+mkHandlePosn h p = HandlePosn h p
data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
deriving (Eq, Ord, Ix, Enum, Read, Show)
@@ -601,17 +576,19 @@ to a previously obtained position {\em p}.
hGetPosn :: Handle -> IO HandlePosn
hGetPosn handle =
wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
- posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block
if posn /= -1 then do
- return (HandlePosn handle posn)
+ return (mkHandlePosn handle (fromInt posn))
else
constructErrorAndFail "hGetPosn"
hSetPosn :: HandlePosn -> IO ()
-hSetPosn (HandlePosn handle posn) =
- wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- not as silly as it looks: the handle may have been closed in the meantime.
+hSetPosn (HandlePosn handle i@(S# _)) = hSetPosn (HandlePosn handle (toBig i))
+hSetPosn (HandlePosn handle (J# s# d#)) =
+ wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do
+ -- not as silly as it looks: the handle may have been closed in the meantime.
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(setFilePosn) fo posn) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (setFilePosn fo (I# s#) d#) -- ConcHask: UNSAFE, may block
if rc == 0 then do
return ()
else
@@ -620,25 +597,24 @@ hSetPosn (HandlePosn handle posn) =
The action @hSeek hdl mode i@ sets the position of handle
@hdl@ depending on @mode@. If @mode@ is
-\begin{itemize}
-\item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@.
-\item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from
-the current position.
-\item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from
-the end of the file.
-\end{itemize}
-Some handles may not be seekable (see @hIsSeekable@), or only support a
-subset of the possible positioning operations (e.g. it may only be
-possible to seek to the end of a tape, or to a positive offset from
-the beginning or current position).
+ * AbsoluteSeek - The position of @hdl@ is set to @i@.
+ * RelativeSeek - The position of @hdl@ is set to offset @i@ from
+ the current position.
+ * SeekFromEnd - The position of @hdl@ is set to offset @i@ from
+ the end of the file.
+
+Some handles may not be seekable (see @hIsSeekable@), or only
+support a subset of the possible positioning operations (e.g. it may
+only be possible to seek to the end of a tape, or to a positive
+offset from the beginning or current position).
It is not possible to set a negative I/O position, or for a physical
file, an I/O position beyond the current end-of-file.
Note:
- - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking
- at or past EOF.
+ - when seeking using @SeekFromEnd@, positive offsets (>=0) means
+ seeking at or past EOF.
- relative seeking on buffered handles can lead to non-obvious results.
\begin{code}
@@ -647,13 +623,13 @@ hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset =
wantSeekableHandle "hSeek" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (seekFile fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block
#else
hSeek handle mode i@(S# _) = hSeek handle mode (toBig i)
hSeek handle mode (J# s# d#) =
wantSeekableHandle "hSeek" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
+ rc <- mayBlock fo (seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block
#endif
if rc == 0 then do
return ()
@@ -745,7 +721,7 @@ getBMode__ :: ForeignObj -> IO (BufferMode, Int)
getBMode__ :: Addr -> IO (BufferMode, Int)
#endif
getBMode__ fo = do
- rc <- CCALL(getBufferMode) fo -- ConcHask: SAFE, won't block
+ rc <- getBufferMode fo -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> return (NoBuffering, 0)
-1 -> return (LineBuffering, default_buffer_size)
@@ -784,7 +760,7 @@ hIsSeekable handle =
SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
AppendHandle -> return False
_ -> do
- rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ rc <- seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block
case (rc::Int) of
0 -> return False
1 -> return True
@@ -813,7 +789,7 @@ hSetEcho handle on = do
ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hSetEcho" handle
_ -> do
- rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block
+ rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
if rc /= ((-1)::Int)
then return ()
else constructErrorAndFail "hSetEcho"
@@ -829,7 +805,7 @@ hGetEcho handle = do
ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetEcho" handle
_ -> do
- rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
case (rc::Int) of
1 -> return True
0 -> return False
@@ -842,7 +818,7 @@ hIsTerminalDevice handle = do
ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle
_ -> do
- rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
+ rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block
case (rc::Int) of
1 -> return True
0 -> return False
@@ -860,7 +836,7 @@ hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
hConnectHdl_ hW hR is_tty =
wantRWHandle "hConnectTo" hW $ \ hW_ ->
wantRWHandle "hConnectTo" hR $ \ hR_ -> do
- CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
+ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
#define FILE_OBJECT ForeignObj
@@ -868,8 +844,6 @@ hConnectHdl_ hW hR is_tty =
#define FILE_OBJECT Addr
#endif
-flushConnectedBuf :: FILE_OBJECT -> IO ()
-flushConnectedBuf fo = CCALL(flushConnectedBuf) fo
\end{code}
As an extension, we also allow characters to be pushed back.
@@ -881,7 +855,7 @@ pushback. (For unbuffered channels, the (default) push-back limit is
hUngetChar :: Handle -> Char -> IO ()
hUngetChar handle c =
wantReadableHandle "hLookAhead" handle $ \ handle_ -> do
- rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block
+ rc <- ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block
if rc == ((-1)::Int)
then constructErrorAndFail "hUngetChar"
else return ()
@@ -902,7 +876,7 @@ slurpFile fname = do
ioError (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- CCALL(allocMemory__) (sz_i::Int)
+ chunk <- allocMemory__ sz_i
if chunk == nullAddr
then do
hClose handle
@@ -910,7 +884,7 @@ slurpFile fname = do
else do
rc <- withHandle_ handle ( \ handle_ -> do
let fo = haFO__ handle_
- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ mayBlock fo (readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block.
)
hClose handle
if rc < (0::Int)
@@ -927,11 +901,7 @@ hFillBufBA handle buf sz
| otherwise =
wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do
let fo = haFO__ handle_
-#ifdef __HUGS__
- rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block.
-#else
- rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
-#endif
+ rc <- mayBlock fo (readChunkBA fo buf sz) -- ConcHask: UNSAFE, may block.
if rc >= (0::Int)
then return rc
else constructErrorAndFail "hFillBufBA"
@@ -946,7 +916,7 @@ hFillBuf handle buf sz
| otherwise =
wantReadableHandle "hFillBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (readChunk fo buf sz) -- ConcHask: UNSAFE, may block.
if rc >= 0
then return rc
else constructErrorAndFail "hFillBuf"
@@ -961,7 +931,7 @@ hPutBuf :: Handle -> Addr -> Int -> IO ()
hPutBuf handle buf len =
wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (writeBuf fo buf len) -- ConcHask: UNSAFE, may block.
if rc == (0::Int)
then return ()
else constructErrorAndFail "hPutBuf"
@@ -971,7 +941,7 @@ hPutBufBA :: Handle -> ByteArray Int -> Int -> IO ()
hPutBufBA handle buf len =
wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do
let fo = haFO__ handle_
- rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (writeBufBA fo buf len) -- ConcHask: UNSAFE, may block.
if rc == (0::Int)
then return ()
else constructErrorAndFail "hPutBuf"
@@ -989,7 +959,7 @@ getHandleFd handle =
ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
- fd <- CCALL(getFileFd) (haFO__ handle_)
+ fd <- getFileFd (haFO__ handle_)
return fd
\end{code}
@@ -1122,7 +1092,6 @@ wantSeekableHandle fun handle act =
ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
- AppendHandle -> ioError not_seekable_error
_ -> act handle_
where
not_seekable_error =
@@ -1154,91 +1123,127 @@ mayBlock fo act = do
rc <- act
case rc of
-5 -> do -- (possibly blocking) read
- fd <- CCALL(getFileFd) fo
+ fd <- getFileFd fo
threadWaitRead fd
mayBlock fo act -- input available, re-try
-6 -> do -- (possibly blocking) write
- fd <- CCALL(getFileFd) fo
+ fd <- getFileFd fo
threadWaitWrite fd
mayBlock fo act -- output possible
-7 -> do -- (possibly blocking) write on connected handle
- fd <- CCALL(getConnFileFd) fo
+ fd <- getConnFileFd fo
threadWaitWrite fd
mayBlock fo act -- output possible
_ -> do
return rc
\end{code}
+Foreign import declarations of helper functions:
\begin{code}
-#ifdef __HUGS__
-type FD = Int
-type Exclusive = Int -- really Bool
-type How = Int
-type Binary = Int
-type OpenStdFlags = Int
-type OpenFlags = Int
-type Readable = Int -- really Bool
-type Flush = Int -- really Bool
-type RC = Int -- standard return code
-
-type IOFileAddr = Addr -- as returned from functions
-type CString = PrimByteArray
-type Bytes = PrimMutableByteArray RealWorld
-#ifndef __PARALLEL_HASKELL__
-type FILE_OBJ = ForeignObj -- as passed into functions
+#ifdef __HUGS__
+type Bytes = PrimByteArray RealWorld
#else
-type FILE_OBJ = Addr
+type Bytes = ByteArray#
#endif
-foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
-foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC
-foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
-foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr
-foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
-foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
-foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC
-foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
-foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC
-foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
-foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD
-foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
-foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int
-foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
-foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD
-foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr
-foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC
-foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
-foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
-foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO ()
-foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO ()
-foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int
-
-foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr
-foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int
-foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int
-
+foreign import "libHS_cbits" "inputReady" unsafe
+ inputReady :: FILE_OBJECT -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "fileGetc" unsafe
+ fileGetc :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "fileLookAhead" unsafe
+ fileLookAhead :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "readBlock" unsafe
+ readBlock :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "readLine" unsafe
+ readLine :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "readChar" unsafe
+ readChar :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "writeFileObject" unsafe
+ writeFileObject :: FILE_OBJECT -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "filePutc" unsafe
+ filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-}
+foreign import "libHS_cbits" "getBufStart" unsafe
+ getBufStart :: FILE_OBJECT -> Int -> IO Addr
+foreign import "libHS_cbits" "getWriteableBuf" unsafe
+ getWriteableBuf :: FILE_OBJECT -> IO Addr
+foreign import "libHS_cbits" "getBufWPtr" unsafe
+ getBufWPtr :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "setBufWPtr" unsafe
+ setBufWPtr :: FILE_OBJECT -> Int -> IO ()
+foreign import "libHS_cbits" "closeFile" unsafe
+ closeFile :: FILE_OBJECT -> Int{-Flush-} -> IO Int{-ret code-}
+foreign import "libHS_cbits" "fileEOF" unsafe
+ fileEOF :: FILE_OBJECT -> IO Int{-ret code-}
+foreign import "libHS_cbits" "setBuffering" unsafe
+ setBuffering :: FILE_OBJECT -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "flushFile" unsafe
+ flushFile :: FILE_OBJECT -> IO Int{-ret code-}
+foreign import "libHS_cbits" "flushConnectedBuf" unsafe
+ flushConnectedBuf :: FILE_OBJECT -> IO ()
+foreign import "libHS_cbits" "getBufferMode" unsafe
+ getBufferMode :: FILE_OBJECT -> IO Int{-ret code-}
+#ifdef __HUGS__
+foreign import "libHS_cbits" "seekFile_int64" unsafe
+ seekFile :: FILE_OBJECT -> Int -> Int64 -> IO Int
+#else
+foreign import "libHS_cbits" "seekFile" unsafe
+ seekFile :: FILE_OBJECT -> Int -> Int -> Bytes -> IO Int
+#endif
+
+foreign import "libHS_cbits" "seekFileP" unsafe
+ seekFileP :: FILE_OBJECT -> IO Int{-ret code-}
+foreign import "libHS_cbits" "setTerminalEcho" unsafe
+ setTerminalEcho :: FILE_OBJECT -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "getTerminalEcho" unsafe
+ getTerminalEcho :: FILE_OBJECT -> IO Int{-ret code-}
+foreign import "libHS_cbits" "isTerminalDevice" unsafe
+ isTerminalDevice :: FILE_OBJECT -> IO Int{-ret code-}
+foreign import "libHS_cbits" "setConnectedTo" unsafe
+ setConnectedTo :: FILE_OBJECT -> FILE_OBJECT -> Int -> IO ()
+foreign import "libHS_cbits" "ungetChar" unsafe
+ ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-}
+foreign import "libHS_cbits" "readChunk" unsafe
+ readChunk :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "readChunk" unsafe
+ readChunkBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-}
+foreign import "libHS_cbits" "writeBuf" unsafe
+ writeBuf :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
+#ifndef __HUGS__
+foreign import "libHS_cbits" "writeBufBA" unsafe
+ writeBufBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-}
#endif
+foreign import "libHS_cbits" "getFileFd" unsafe
+ getFileFd :: FILE_OBJECT -> IO Int{-fd-}
+#ifdef __HUGS__
+foreign import "libHS_cbits" "fileSize_int64" unsafe
+ fileSize_int64 :: FILE_OBJECT -> Bytes -> IO Int{-ret code-}
+#else
+foreign import "libHS_cbits" "fileSize" unsafe
+ fileSize :: FILE_OBJECT -> Bytes -> IO Int{-ret code-}
+#endif
+
+foreign import "libHS_cbits" "getFilePosn" unsafe
+ getFilePosn :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "setFilePosn" unsafe
+ setFilePosn :: FILE_OBJECT -> Int -> ByteArray# -> IO Int
+foreign import "libHS_cbits" "getConnFileFd" unsafe
+ getConnFileFd :: FILE_OBJECT -> IO Int{-fd-}
+foreign import "libHS_cbits" "getLock" unsafe
+ getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-}
+foreign import "libHS_cbits" "openStdFile" unsafe
+ openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-}
+foreign import "libHS_cbits" "openFile" unsafe
+ primOpenFile :: ByteArray Int{-CString-}
+ -> Int{-How-}
+ -> Int{-Binary-}
+ -> IO Addr {-file obj-}
+foreign import "libHS_cbits" "const_BUFSIZ" unsafe
+ const_BUFSIZ :: Int
+
+foreign import "libHS_cbits" "setBinaryMode__"
+ setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 2e43613234ca44deb21f318048264bd29f3e08d5..caa50db1f8b10beb8b4e56f4ed3a43c4e91b4c7f 100644
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.12 1999/08/23 12:53:25 keithw Exp $
+% $Id: PrelIOBase.lhs,v 1.13 1999/09/19 19:12:41 sof Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
@@ -33,14 +33,9 @@ import PrelArr ( MutableVar, readVar )
#endif
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
#define unpackCString primUnpackString
-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
#endif
#ifndef __PARALLEL_HASKELL__
@@ -306,8 +301,8 @@ constructError call_site = constructErrorMsg call_site Nothing
constructErrorMsg :: String -> Maybe String -> IO IOError
constructErrorMsg call_site reason =
- CCALL(getErrType__) >>= \ errtype ->
- CCALL(getErrStr__) >>= \ str ->
+ getErrType__ >>= \ errtype ->
+ getErrStr__ >>= \ str ->
let
iot =
case (errtype::Int) of
@@ -476,7 +471,7 @@ instance Show Handle where
BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
where
def :: Int
- def = unsafePerformIO (CCALL(getBufSize) fo)
+ def = unsafePerformIO (getBufSize fo)
mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
mkBuffer__ fo sz_in_bytes = do
@@ -484,11 +479,11 @@ mkBuffer__ fo sz_in_bytes = do
case sz_in_bytes of
0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
_ -> do
- chunk <- CCALL(allocMemory__) sz_in_bytes
+ chunk <- allocMemory__ sz_in_bytes
if chunk == nullAddr
then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
else return chunk
- CCALL(setBuf) fo chunk sz_in_bytes
+ setBuf fo chunk sz_in_bytes
\end{code}
@@ -543,3 +538,19 @@ data BufferMode
{- Read instance defined in IO. -}
\end{code}
+
+Foreign import declarations to helper routines:
+
+\begin{code}
+foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr
+foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
+foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
+
+foreign import "libHS_cbits" "allocMemory__" unsafe
+ allocMemory__ :: Int -> IO Addr
+foreign import "libHS_cbits" "getBufSize" unsafe
+ getBufSize :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "setBuf" unsafe
+ setBuf :: FILE_OBJECT -> Addr -> Int -> IO ()
+
+\end{code}
diff --git a/ghc/lib/std/PrelNumExtra.lhs b/ghc/lib/std/PrelNumExtra.lhs
index 9e870c0e08c03053e741d9303c3fcab3de00f043..b2bb63858d24f1474d5c4e9162ba5ffcf0ef68dc 100644
--- a/ghc/lib/std/PrelNumExtra.lhs
+++ b/ghc/lib/std/PrelNumExtra.lhs
@@ -28,7 +28,7 @@ import Maybe ( fromMaybe )
import PrelArr ( Array, array, (!) )
import PrelIOBase ( unsafePerformIO )
import PrelCCall () -- we need the definitions of CCallable and
- -- CReturnable for the _ccall_s herein.
+ -- CReturnable for the foreign calls herein.
\end{code}
%*********************************************************
diff --git a/ghc/lib/std/PrelStable.lhs b/ghc/lib/std/PrelStable.lhs
index 664ade7b79ddee01cce1ace7a561470358665a39..fb121584d5fd3c0a05f2597f47f334c9d7a27875 100644
--- a/ghc/lib/std/PrelStable.lhs
+++ b/ghc/lib/std/PrelStable.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: PrelStable.lhs,v 1.1 1999/01/26 12:25:01 simonm Exp $
+% $Id: PrelStable.lhs,v 1.2 1999/09/19 19:12:42 sof Exp $
%
% (c) The GHC Team, 1992-1999
%
@@ -28,14 +28,13 @@ instance CReturnable (StablePtr a)
makeStablePtr :: a -> IO (StablePtr a)
deRefStablePtr :: StablePtr a -> IO a
-freeStablePtr :: StablePtr a -> IO ()
+foreign import "freeStablePtr" freeStablePtr :: StablePtr a -> IO ()
makeStablePtr a = IO $ \ s ->
case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)
deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s
-freeStablePtr sp = _ccall_ freeStablePtr sp
instance Eq (StablePtr a) where
(StablePtr sp1) == (StablePtr sp2) =
diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs
index 2eecaae73095274b838cf9a60aa359d350ef3554..b9bd4caa9efc4d647ae0b6263766e107b3112b44 100644
--- a/ghc/lib/std/Time.lhs
+++ b/ghc/lib/std/Time.lhs
@@ -44,7 +44,7 @@ import PrelHandle
import PrelArr
import PrelST
import PrelAddr
-import PrelPack ( unpackCString )
+import PrelPack ( unpackCString, new_ps_array )
#endif
import Ix
@@ -101,7 +101,7 @@ instance Show ClockTime where
showsPrec _ (TOD (J# s# d#) _nsec) =
showString $ unsafePerformIO $ do
buf <- allocChars 38 -- exactly enough for error message
- str <- _ccall_ showTime (I# s#) d# buf
+ str <- showTime (I# s#) d# buf
return (unpackCString str)
showList = showList__ (showsPrec 0)
@@ -180,12 +180,11 @@ data TimeDiff
@getClockTime@ returns the current time in its internal representation.
\begin{code}
-#ifdef __HUGS__
getClockTime :: IO ClockTime
getClockTime = do
i1 <- malloc1
i2 <- malloc1
- rc <- prim_getClockTime i1 i2
+ rc <- primGetClockTime i1 i2
if rc == 0
then do
sec <- cvtUnsigned i1
@@ -194,22 +193,10 @@ getClockTime = do
else
constructErrorAndFail "getClockTime"
where
+#ifdef __HUGS__
malloc1 = primNewByteArray sizeof_int64
cvtUnsigned arr = primReadInt64Array arr 0
#else
-getClockTime :: IO ClockTime
-getClockTime = do
- i1 <- malloc1
- i2 <- malloc1
- rc <- _ccall_ getClockTime i1 i2
- if rc == (0 ::Int)
- then do
- sec <- cvtUnsigned i1
- nsec <- cvtUnsigned i2
- return (TOD sec (nsec * 1000))
- else
- constructErrorAndFail "getClockTime"
- where
malloc1 = IO $ \ s# ->
case newIntArray# 1# s# of
(# s2#, barr# #) ->
@@ -244,7 +231,7 @@ addToClockTime :: TimeDiff -> ClockTime -> ClockTime
addToClockTime (TimeDiff year mon day hour min sec psec)
(TOD c_sec c_psec) = unsafePerformIO $ do
res <- allocWords sizeof_int64
- rc <- prim_toClockSec year mon day hour min sec 0 res
+ rc <- toClockSec year mon day hour min sec 0 res
if rc /= (0::Int)
then do
diff_sec <- primReadInt64Array res 0
@@ -256,14 +243,14 @@ addToClockTime (TimeDiff year mon day hour min sec psec)
addToClockTime :: TimeDiff -> ClockTime -> ClockTime
addToClockTime (TimeDiff year mon day hour min sec psec)
(TOD c_sec c_psec) = unsafePerformIO $ do
- res <- allocWords (``sizeof(time_t)'')
- ptr <- _ccall_ toClockSec year mon day hour min sec (0::Int) res
- let (A# ptr#) = ptr
- if ptr /= nullAddr
- then let
- diff_sec = (int2Integer (indexIntOffAddr# ptr# 0#))
+ res <- stToIO (newIntArray (0,sizeof_time_t))
+ rc <- toClockSec year mon day hour min sec (0::Int) res
+ if rc /= 0
+ then do
+ diff_sec_i <- stToIO (readIntArray res 0)
+ let
+ diff_sec = int2Integer (case diff_sec_i of I# i# -> i#)
diff_psec = psec
- in
return (TOD (c_sec + diff_sec) (c_psec + diff_psec))
else
error "Time.addToClockTime: can't perform conversion of TimeDiff"
@@ -346,7 +333,7 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is
else
unsafePerformIO ( do
res <- allocWords sizeof_int64
- rc <- prim_toClockSec year mon mday hour min sec isDst res
+ rc <- toClockSec year mon mday hour min sec isDst res
if rc /= (0::Int)
then do
tm <- primReadInt64Array res 0
@@ -360,24 +347,24 @@ toCalendarTime :: ClockTime -> IO CalendarTime
toCalendarTime (TOD (S# i) psec)
= case int2Integer# i of (# s, d #) -> toCalendarTime (TOD (J# s d) psec)
toCalendarTime (TOD (J# s# d#) psec) = do
- res <- allocWords (``sizeof(struct tm)''::Int)
+ res <- allocWords sizeof_struct_tm
zoneNm <- allocChars 32
- _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm
- tm <- _ccall_ toLocalTime (I# s#) d# res
- if tm == nullAddr
+ prim_SETZONE res zoneNm
+ rc <- prim_toLocalTime (I# s#) d# res
+ if rc == 0
then constructErrorAndFail "Time.toCalendarTime: out of range"
else do
- sec <- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm
- min <- _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm
- hour <- _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm
- mday <- _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm
- mon <- _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm
- year <- _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm
- wday <- _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm
- yday <- _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm
- isdst <- _casm_ ``%r = ((struct tm *)%0)->tm_isdst;'' tm
- zone <- _ccall_ get_ZONE tm
- tz <- _ccall_ GMTOFF tm
+ sec <- get_tm_sec res
+ min <- get_tm_min res
+ hour <- get_tm_hour res
+ mday <- get_tm_mday res
+ mon <- get_tm_mon res
+ year <- get_tm_year res
+ wday <- get_tm_wday res
+ yday <- get_tm_yday res
+ isdst <- get_tm_isdst res
+ zone <- get_ZONE res
+ tz <- get_GMTOFF res
let tzname = unpackCString zone
return (CalendarTime (1900+year) mon mday hour min sec psec
(toEnum wday) yday tzname tz (isdst /= (0::Int)))
@@ -386,21 +373,21 @@ toUTCTime :: ClockTime -> CalendarTime
toUTCTime (TOD (S# i) psec)
= case int2Integer# i of (# s, d #) -> toUTCTime (TOD (J# s d) psec)
toUTCTime (TOD (J# s# d#) psec) = unsafePerformIO $ do
- res <- allocWords (``sizeof(struct tm)''::Int)
+ res <- allocWords sizeof_struct_tm
zoneNm <- allocChars 32
- _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm
- tm <- _ccall_ toUTCTime (I# s#) d# res
- if tm == nullAddr
+ prim_SETZONE res zoneNm
+ rc <- prim_toUTCTime (I# s#) d# res
+ if rc == 0
then error "Time.toUTCTime: out of range"
else do
- sec <- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm
- min <- _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm
- hour <- _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm
- mday <- _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm
- mon <- _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm
- year <- _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm
- wday <- _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm
- yday <- _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm
+ sec <- get_tm_sec res
+ min <- get_tm_min res
+ hour <- get_tm_hour res
+ mday <- get_tm_mday res
+ mon <- get_tm_mon res
+ year <- get_tm_year res
+ wday <- get_tm_wday res
+ yday <- get_tm_yday res
return (CalendarTime (1900+year) mon mday hour min sec psec
(toEnum wday) yday "UTC" 0 False)
@@ -412,11 +399,12 @@ toClockTime (CalendarTime year mon mday hour min sec psec _wday _yday _tzname tz
error "Time.toClockTime: timezone offset out of range"
else
unsafePerformIO ( do
- res <- allocWords (``sizeof(time_t)'')
- ptr <- _ccall_ toClockSec year mon mday hour min sec isDst res
- let (A# ptr#) = ptr
- if ptr /= nullAddr
- then return (TOD (int2Integer (indexIntOffAddr# ptr# 0#)) psec)
+ res <- stToIO (newIntArray (0, sizeof_time_t))
+ rc <- toClockSec year mon mday hour min sec isDst res
+ if rc /= 0
+ then do
+ i <- stToIO (readIntArray res 0)
+ return (TOD (int2Integer (case i of I# i# -> i#)) psec)
else error "Time.toClockTime: can't perform conversion"
)
where
@@ -439,17 +427,12 @@ allocChars size = primNewByteArray size
allocWords :: Int -> IO (PrimMutableByteArray RealWorld)
allocWords size = primNewByteArray size
#else
-allocChars :: Int -> IO (MutableByteArray RealWorld ())
-allocChars (I# size#) = IO $ \ s# ->
- case newCharArray# size# s# of
- (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot barr# #)
- where
- bot = error "Time.allocChars"
+allocChars :: Int -> IO (MutableByteArray RealWorld Int)
+allocChars (I# size#) = stToIO (new_ps_array size#)
-- Allocate a mutable array of words with no indices
-allocWords :: Int -> IO (MutableByteArray RealWorld ())
+allocWords :: Int -> IO (MutableByteArray RealWorld Int)
allocWords (I# size#) = IO $ \ s# ->
case newIntArray# size# s# of
(# s2#, barr# #) ->
@@ -578,33 +561,55 @@ formatTimeDiff l fmt (TimeDiff year month day hour min sec _)
\end{code}
\begin{code}
-#ifdef __HUGS__
-foreign import ccall "libHS_cbits.so" "get_tm_sec" get_tm_sec :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_min" get_tm_min :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_hour" get_tm_hour :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_mday" get_tm_mday :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_mon" get_tm_mon :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_year" get_tm_year :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_wday" get_tm_wday :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_yday" get_tm_yday :: Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "get_tm_isdst" get_tm_isdst :: Bytes -> IO Int
-
-foreign import ccall "libHS_cbits.so" "prim_ZONE" prim_ZONE :: Bytes -> IO Addr
-foreign import ccall "libHS_cbits.so" "prim_GMTOFF" prim_GMTOFF :: Bytes -> IO Int
-
-foreign import ccall "libHS_cbits.so" "prim_SETZONE" prim_SETZONE :: Bytes -> Bytes -> IO Int
-
-foreign import ccall "libHS_cbits.so" "sizeof_word" sizeof_word :: Int
-foreign import ccall "libHS_cbits.so" "sizeof_struct_tm" sizeof_struct_tm :: Int
-foreign import ccall "libHS_cbits.so" "sizeof_time_t" sizeof_time_t :: Int
+foreign import "libHS_cbits" "get_tm_sec" get_tm_sec :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_min" get_tm_min :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_hour" get_tm_hour :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_mday" get_tm_mday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_mon" get_tm_mon :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_year" get_tm_year :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_wday" get_tm_wday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_yday" get_tm_yday :: MBytes -> IO Int
+foreign import "libHS_cbits" "get_tm_isdst" get_tm_isdst :: MBytes -> IO Int
+
+foreign import "libHS_cbits" "prim_ZONE" prim_ZONE :: Bytes -> IO Addr
+foreign import "libHS_cbits" "prim_GMTOFF" prim_GMTOFF :: Bytes -> IO Int
+
+foreign import "libHS_cbits" "sizeof_struct_tm" sizeof_struct_tm :: Int
+#ifdef __HUGS__
-- believed to be at least 1 bit (the sign bit!) bigger than sizeof_time_t
sizeof_int64 :: Int
sizeof_int64 = 8
+#endif
+
+type MBytes = MutableByteArray RealWorld Int
-foreign import ccall "libHS_cbits.so" "prim_getClockTime" prim_getClockTime :: Bytes -> Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "prim_toClockSec" prim_toClockSec :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "prim_toLocalTime" prim_toLocalTime :: Int64 -> Bytes -> IO Int
-foreign import ccall "libHS_cbits.so" "prim_toUTCTime" prim_toUTCTime :: Int64 -> Bytes -> IO Int
+foreign import "libHS_cbits" "sizeof_time_t" sizeof_time_t :: Int
+
+foreign import "libHS_cbits" "prim_SETZONE" prim_SETZONE :: MBytes -> MBytes -> IO Int
+#ifdef __HUGS__
+foreign import "libHS_cbits" "prim_toLocalTime" prim_toLocalTime :: Int64 -> MBytes -> IO Int
+foreign import "libHS_cbits" "prim_toUTCTime" prim_toUTCTime :: Int64 -> MBytes -> IO Int
+#else
+foreign import "libHS_cbits" "toLocalTime" prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int
+foreign import "libHS_cbits" "toUTCTime" prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int
#endif
+
+foreign import "libHS_cbits" "get_ZONE" get_ZONE :: MBytes -> IO Addr
+foreign import "libHS_cbits" "GMTOFF" get_GMTOFF :: MBytes -> IO Int
+
+
+foreign import "libHS_cbits" "toClockSec"
+ toClockSec :: Int -> Int -> Int -> Int -> Int
+ -> Int -> Int -> MBytes -> IO Int
+
+foreign import "libHS_cbits" "prim_getClockTime"
+ primGetClockTime :: MutableByteArray RealWorld Int
+ -> MutableByteArray RealWorld Int
+ -> IO Int
+foreign import "libHS_cbits" "showTime"
+ showTime :: Int
+ -> Bytes
+ -> MBytes
+ -> IO Addr{-packed C string -}
\end{code}