X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fhugs%2FPrelude.hs;h=69c9db635f1f81a2779d47f5c4914eb7808c1bea;hb=618348854155e48b3abb64809065601c586d0553;hp=f1fe9a742bcd6d27c3182d5a6350224c876587c9;hpb=ac43cdb2d5902f1eb90f97db2f1a70c50d2a0aff;p=ghc-hetmet.git diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index f1fe9a7..69c9db6 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -60,7 +60,8 @@ module Prelude ( -- module Ratio, Ratio, Rational, (%), numerator, denominator, approxRational, -- Non-standard exports - IO(..), IOResult(..), Addr, + IO(..), IOResult(..), Addr, StablePtr, + makeStablePtr, freeStablePtr, deRefStablePtr, Bool(False, True), Maybe(Nothing, Just), @@ -93,7 +94,7 @@ module Prelude ( isInfinite, isDenormalized, isIEEE, isNegativeZero), Monad((>>=), (>>), return, fail), Functor(fmap), - mapM, mapM_, accumulate, sequence, (=<<), + mapM, mapM_, sequence, sequence_, (=<<), maybe, either, (&&), (||), not, otherwise, subtract, even, odd, gcd, lcm, (^), (^^), @@ -102,17 +103,39 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) + , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar + , ThreadId, forkIO ,trace - -- Arrrggghhh!!! Help! Help! Help! - -- What?! Prelude.hs doesn't even _define_ most of these things! + + , STRef, newSTRef, readSTRef, writeSTRef + , IORef, newIORef, readIORef, writeIORef + + -- This lot really shouldn't be exported, but are needed to + -- implement various libs. ,primCompAux,PrimArray,primRunST,primNewArray,primWriteArray ,primUnsafeFreezeArray,primIndexArray,primGetRawArgs,primGetEnv ,nh_stdin,nh_stdout,nh_stderr,copy_String_to_cstring,nh_open ,nh_free,nh_close,nh_errno,nh_flush,nh_read,primIntToChar - ,unsafeInterleaveIO,nh_write,primCharToInt + ,unsafeInterleaveIO,nh_write,primCharToInt, + nullAddr, incAddr, isNullAddr, + nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID, + nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction, + + Word, + primGtWord, primGeWord, primEqWord, primNeWord, + primLtWord, primLeWord, primMinWord, primMaxWord, + primPlusWord, primMinusWord, primTimesWord, primQuotWord, + primRemWord, primQuotRemWord, primNegateWord, primAndWord, + primOrWord, primXorWord, primNotWord, primShiftLWord, + primShiftRAWord, primShiftRLWord, primIntToWord, primWordToInt, + + primAndInt, primOrInt, primXorInt, primNotInt, + primShiftLInt, primShiftRAInt, primShiftRLInt, + + primAddrToInt, primIntToAddr, + + primDoubleToFloat, primFloatToDouble, - -- ToDo: rm -- these are only for debugging - ,primPlusInt,primEqChar,primRunIO ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -398,20 +421,20 @@ class Monad m where p >> q = p >>= \ _ -> q fail s = error s -accumulate :: Monad m => [m a] -> m [a] -accumulate [] = return [] -accumulate (c:cs) = do x <- c - xs <- accumulate cs - return (x:xs) +sequence :: Monad m => [m a] -> m [a] +sequence [] = return [] +sequence (c:cs) = do x <- c + xs <- sequence cs + return (x:xs) -sequence :: Monad m => [m a] -> m () -sequence = foldr (>>) (return ()) +sequence_ :: Monad m => [m a] -> m () +sequence_ = foldr (>>) (return ()) mapM :: Monad m => (a -> m b) -> [a] -> m [b] -mapM f = accumulate . map f +mapM f = sequence . map f mapM_ :: Monad m => (a -> m b) -> [a] -> m () -mapM_ f = sequence . map f +mapM_ f = sequence_ . map f (=<<) :: Monad m => (a -> m b) -> m a -> m b f =<< x = x >>= f @@ -629,14 +652,6 @@ instance Show a => Show [a] where -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show) -- etc.. --- Functions ---------------------------------------------------------------- - -instance Show (a -> b) where - showsPrec p f = showString "<>" - -instance Functor ((->) a) where - fmap = (.) - -- Standard Integral types -------------------------------------------------- data Int -- builtin datatype of fixed size integers @@ -1383,7 +1398,7 @@ nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] lexLitChar :: ReadS String lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- " lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] lexEsc s@(d:_) | isDigit d = lexDigits s lexEsc s@(c:_) | isUpper c @@ -1537,8 +1552,8 @@ primPmInt n x = fromInt n == x primPmInteger :: Num a => Integer -> a -> Bool primPmInteger n x = fromInteger n == x -primPmFlt :: Fractional a => Double -> a -> Bool -primPmFlt n x = fromDouble n == x +primPmDouble :: Fractional a => Double -> a -> Bool +primPmDouble n x = fromDouble n == x -- ToDo: make the message more informative. primPmFail :: a @@ -1548,6 +1563,13 @@ primPmFail = error "Pattern Match Failure" primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a primMkIO = ST +primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +primCreateAdjThunk fun typestr callconv + = do sp <- makeStablePtr fun + p <- copy_String_to_cstring typestr -- is never freed + a <- primCreateAdjThunkARCH sp p callconv + return a + -- The following primitives are only needed if (n+k) patterns are enabled: primPmNpk :: Integral a => Int -> a -> Maybe a primPmNpk n x = if n'<=x then Just (x-n') else Nothing @@ -1601,13 +1623,12 @@ catch m k e2ioe other = IOError (show other) putChar :: Char -> IO () -putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c) +putChar c = nh_stdout >>= \h -> nh_write h c putStr :: String -> IO () -putStr s = --mapM_ putChar s -- correct, but slow - nh_stdout >>= \h -> - let loop [] = return () - loop (c:cs) = nh_write h (primCharToInt c) >> loop cs +putStr s = nh_stdout >>= \h -> + let loop [] = nh_flush h + loop (c:cs) = nh_write h c >> loop cs in loop s putStrLn :: String -> IO () @@ -1641,7 +1662,7 @@ readFile fname nh_open ptr 0 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> - if (h == 0 || errno /= 0) + if (isNullAddr h || errno /= 0) then (ioError.IOError) ("readFile: can't open file " ++ fname) else readfromhandle h @@ -1651,18 +1672,17 @@ writeFile fname contents nh_open ptr 1 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> - if (h == 0 || errno /= 0) + if (isNullAddr h || errno /= 0) then (ioError.IOError) ("writeFile: can't create file " ++ fname) else writetohandle fname h contents - appendFile :: FilePath -> String -> IO () appendFile fname contents = copy_String_to_cstring fname >>= \ptr -> nh_open ptr 2 >>= \h -> nh_free ptr >> nh_errno >>= \errno -> - if (h == 0 || errno /= 0) + if (isNullAddr h || errno /= 0) then (ioError.IOError) ("appendFile: can't open file " ++ fname) else writetohandle fname h contents @@ -1693,47 +1713,49 @@ instance Show Exception where data IOResult = IOResult deriving (Show) -type FILE_STAR = Int -- FILE * -type Ptr = Int -- char * - -foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR -foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR -foreign import stdcall "nHandle.so" "nh_stderr" nh_stderr :: IO FILE_STAR -foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO () -foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int -foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR -foreign import stdcall "nHandle.so" "nh_flush" nh_flush :: FILE_STAR -> IO () -foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO () -foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int - -foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Ptr -foreign import stdcall "nHandle.so" "nh_free" nh_free :: Ptr -> IO () -foreign import stdcall "nHandle.so" "nh_store" nh_store :: Ptr -> Int -> IO () -foreign import stdcall "nHandle.so" "nh_load" nh_load :: Ptr -> IO Int - -foreign import stdcall "nHandle.so" "nh_argc" nh_argc :: IO Int -foreign import stdcall "nHandle.so" "nh_argvb" nh_argvb :: Int -> Int -> IO Int -foreign import stdcall "nHandle.so" "nh_getenv" nh_getenv :: Ptr -> IO Ptr - -copy_String_to_cstring :: String -> IO Ptr +type FILE_STAR = Addr -- FILE * + +foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR +foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR +foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR +foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO () +foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int +foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR +foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO () +foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO () +foreign import "nHandle" "nh_errno" nh_errno :: IO Int + +foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr +foreign import "nHandle" "nh_free" nh_free :: Addr -> IO () +foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO () +foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char +foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr +foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int +foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int +foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int +foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO () +foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int + +foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double +foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double + +copy_String_to_cstring :: String -> IO Addr copy_String_to_cstring s = nh_malloc (1 + length s) >>= \ptr0 -> - let loop ptr [] = nh_store ptr 0 >> return ptr0 - loop ptr (c:cs) = --trace ("Out `" ++ [c] ++ "'") ( - nh_store ptr (primCharToInt c) >> loop (ptr+1) cs - --) + let loop ptr [] = nh_store ptr (chr 0) >> return ptr0 + loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs in - loop ptr0 s + if isNullAddr ptr0 + then error "copy_String_to_cstring: malloc failed" + else loop ptr0 s -copy_cstring_to_String :: Ptr -> IO String +copy_cstring_to_String :: Addr -> IO String copy_cstring_to_String ptr = nh_load ptr >>= \ci -> - if ci == 0 + if ci == '\0' then return [] - else copy_cstring_to_String (ptr+1) >>= \cs -> - --trace ("In " ++ show ci) ( - return ((primIntToChar ci) : cs) - --) + else copy_cstring_to_String (incAddr ptr) >>= \cs -> + return (ci : cs) readfromhandle :: FILE_STAR -> IO String readfromhandle h @@ -1751,28 +1773,24 @@ writetohandle fname h [] then return () else error ( "writeFile/appendFile: error closing file " ++ fname) writetohandle fname h (c:cs) - = nh_write h (primCharToInt c) >> - writetohandle fname h cs + = nh_write h c >> writetohandle fname h cs primGetRawArgs :: IO [String] primGetRawArgs - = nh_argc >>= \argc -> - accumulate (map (get_one_arg 0) [0 .. argc-1]) + = primGetArgc >>= \argc -> + sequence (map get_one_arg [0 .. argc-1]) where - get_one_arg :: Int -> Int -> IO String - get_one_arg offset argno - = nh_argvb argno offset >>= \cb -> - if cb == 0 - then return [] - else get_one_arg (offset+1) argno >>= \s -> - return ((primIntToChar cb):s) + get_one_arg :: Int -> IO String + get_one_arg argno + = primGetArgv argno >>= \a -> + copy_cstring_to_String a primGetEnv :: String -> IO String primGetEnv v = copy_String_to_cstring v >>= \ptr -> nh_getenv ptr >>= \ptr2 -> nh_free ptr >> - if ptr2 == 0 + if isNullAddr ptr2 then return [] else copy_cstring_to_String ptr2 >>= \result -> @@ -1788,7 +1806,6 @@ newtype ST s a = ST (s -> (a,s)) data RealWorld type IO a = ST RealWorld a - --primRunST :: (forall s. ST s a) -> a primRunST :: ST RealWorld a -> a primRunST m = fst (unST m theWorld) @@ -1799,27 +1816,50 @@ primRunST m = fst (unST m theWorld) unST (ST a) = a instance Functor (ST s) where - fmap f x = x >>= (return . f) + fmap f x = x >>= (return . f) instance Monad (ST s) where - m >> k = m >>= \ _ -> k - return x = ST $ \ s -> (x,s) - m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' } + m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' }) + return x = ST (\s -> (x,s)) + m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' }) +-- Library IO has a global variable which accumulates Handles +-- as they are opened. We keep here a second global variable +-- into which a cleanup action may be specified. When evaluation +-- finishes, either normally or as a result of System.exitWith, +-- this cleanup action is run, closing all known-about Handles. +-- Doing it like this means the Prelude does not have to know +-- anything about the grotty details of the Handle implementation. +prelCleanupAfterRunAction :: IORef (Maybe (IO ())) +prelCleanupAfterRunAction = primRunST (newIORef Nothing) + -- used when Hugs invokes top level function -primRunIO :: IO () -> () -primRunIO m - = protect (fst (unST m realWorld)) +primRunIO_hugs_toplevel :: IO a -> () +primRunIO_hugs_toplevel m + = protect 5 (fst (unST composite_action realWorld)) where - realWorld = error "panic: Hugs entered the real world" - protect :: () -> () - protect comp - = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) - -trace :: String -> a -> a + composite_action + = do writeIORef prelCleanupAfterRunAction Nothing + m + cleanup_handles <- readIORef prelCleanupAfterRunAction + case cleanup_handles of + Nothing -> return () + Just xx -> xx + + realWorld = error "primRunIO: entered the RealWorld" + protect :: Int -> () -> () + protect 0 comp + = comp + protect n comp + = primCatch (protect (n-1) comp) + (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) + +trace, trace_quiet :: String -> a -> a trace s x - = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + = trace_quiet ("trace: " ++ s) x +trace_quiet s x + = (primRunST (putStr (s ++ "\n"))) `seq` x unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) @@ -1829,12 +1869,14 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, ForeignObj, Prim*Array ---------------------------------------- +-- Word, Addr, StablePtr, Prim*Array ----------------------------------------- ------------------------------------------------------------------------------ data Addr -nullAddr = primIntToAddr 0 +nullAddr = primIntToAddr 0 +incAddr a = primIntToAddr (1 + primAddrToInt a) +isNullAddr a = 0 == primAddrToInt a instance Eq Addr where (==) = primEqAddr @@ -1846,7 +1888,6 @@ instance Ord Addr where (>=) = primGeAddr (>) = primGtAddr - data Word instance Eq Word where @@ -1859,186 +1900,123 @@ instance Ord Word where (>=) = primGeWord (>) = primGtWord +data StablePtr a ---data ForeignObj ---makeForeignObj :: Addr -> IO ForeignObj ---makeForeignObj = primMakeForeignObj +makeStablePtr :: a -> IO (StablePtr a) +makeStablePtr = primMakeStablePtr +deRefStablePtr :: StablePtr a -> IO a +deRefStablePtr = primDeRefStablePtr +freeStablePtr :: StablePtr a -> IO () +freeStablePtr = primFreeStablePtr data PrimArray a -- immutable arrays with Int indices data PrimByteArray -data Ref s a -- mutable variables +data STRef s a -- mutable variables data PrimMutableArray s a -- mutable arrays with Int indices data PrimMutableByteArray s +newSTRef :: a -> ST s (STRef s a) +newSTRef = primNewRef +readSTRef :: STRef s a -> ST s a +readSTRef = primReadRef +writeSTRef :: STRef s a -> a -> ST s () +writeSTRef = primWriteRef + +type IORef a = STRef RealWorld a +newIORef :: a -> IO (IORef a) +newIORef = primNewRef +readIORef :: IORef a -> IO a +readIORef = primReadRef +writeIORef :: IORef a -> a -> IO () +writeIORef = primWriteRef ------------------------------------------------------------------------------ --- hooks to call libHS_cbits ------------------------------------------------- +-- ThreadId, MVar, concurrency stuff ----------------------------------------- ------------------------------------------------------------------------------ -{- -type FILE_OBJ = ForeignObj -- as passed into functions -type CString = PrimByteArray -type How = Int -type Binary = Int -type OpenFlags = Int -type IOFileAddr = Addr -- as returned from functions -type FD = Int -type OpenStdFlags = Int -type Readable = Int -- really Bool -type Exclusive = Int -- really Bool -type RC = Int -- standard return code -type Bytes = PrimMutableByteArray RealWorld -type Flush = Int -- really Bool - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - freeStdFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - freeFileObject :: ForeignObj -> IO () - -foreign import stdcall "libHS_cbits.so" "setBuf" - prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "getBufSize" - prim_getBufSize :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "inputReady" - prim_inputReady :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileGetc" - prim_fileGetc :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "fileLookAhead" - prim_fileLookAhead :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readBlock" - prim_readBlock :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readLine" - prim_readLine :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "readChar" - prim_readChar :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "writeFileObject" - prim_writeFileObject :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "filePutc" - prim_filePutc :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "getBufStart" - prim_getBufStart :: FILE_OBJ -> Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getWriteableBuf" - prim_getWriteableBuf :: FILE_OBJ -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getBufWPtr" - prim_getBufWPtr :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setBufWPtr" - prim_setBufWPtr :: FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "closeFile" - prim_closeFile :: FILE_OBJ -> Flush -> IO RC - -foreign import stdcall "libHS_cbits.so" "fileEOF" - prim_fileEOF :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "setBuffering" - prim_setBuffering :: FILE_OBJ -> Int -> IO RC +data MVar a -foreign import stdcall "libHS_cbits.so" "flushFile" - prim_flushFile :: FILE_OBJ -> IO RC +newEmptyMVar :: IO (MVar a) +newEmptyMVar = primNewEmptyMVar -foreign import stdcall "libHS_cbits.so" "getBufferMode" - prim_getBufferMode :: FILE_OBJ -> IO RC +putMVar :: MVar a -> a -> IO () +putMVar = primPutMVar -foreign import stdcall "libHS_cbits.so" "seekFileP" - prim_seekFileP :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setTerminalEcho" - prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getTerminalEcho" - prim_getTerminalEcho :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "isTerminalDevice" - prim_isTerminalDevice :: FILE_OBJ -> IO RC - -foreign import stdcall "libHS_cbits.so" "setConnectedTo" - prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () - -foreign import stdcall "libHS_cbits.so" "ungetChar" - prim_ungetChar :: FILE_OBJ -> Char -> IO RC - -foreign import stdcall "libHS_cbits.so" "readChunk" - prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "writeBuf" - prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFileFd" - prim_getFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "fileSize_int64" - prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC - -foreign import stdcall "libHS_cbits.so" "getFilePosn" - prim_getFilePosn :: FILE_OBJ -> IO Int - -foreign import stdcall "libHS_cbits.so" "setFilePosn" - prim_setFilePosn :: FILE_OBJ -> Int -> IO Int - -foreign import stdcall "libHS_cbits.so" "getConnFileFd" - prim_getConnFileFd :: FILE_OBJ -> IO FD - -foreign import stdcall "libHS_cbits.so" "allocMemory__" - prim_allocMemory__ :: Int -> IO Addr - -foreign import stdcall "libHS_cbits.so" "getLock" - prim_getLock :: FD -> Exclusive -> IO RC - -foreign import stdcall "libHS_cbits.so" "openStdFile" - prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "openFile" - prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr - -foreign import stdcall "libHS_cbits.so" "freeFileObject" - prim_freeFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" - prim_freeStdFileObject :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" - const_BUFSIZ :: Int - -foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" - prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" - prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" - prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" - prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "getErrStr__" - prim_getErrStr__ :: IO Addr - -foreign import stdcall "libHS_cbits.so" "getErrNo__" - prim_getErrNo__ :: IO Int - -foreign import stdcall "libHS_cbits.so" "getErrType__" - prim_getErrType__ :: IO Int +takeMVar :: MVar a -> IO a +takeMVar m + = ST (\world -> primTakeMVar m cont world) + where + -- cont :: a -> RealWorld -> (a,RealWorld) + -- where 'a' is as in the top-level signature + cont x world = (x,world) + + -- the type of the handwritten BCO (threesome) primTakeMVar is + -- primTakeMVar :: MVar a + -- -> (a -> RealWorld -> (a,RealWorld)) + -- -> RealWorld + -- -> (a,RealWorld) + -- + -- primTakeMVar behaves like this: + -- + -- primTakeMVar (MVar# m#) cont world + -- = primTakeMVar_wrk m# cont world + -- + -- primTakeMVar_wrk m# cont world + -- = cont (takeMVar# m#) world + -- + -- primTakeMVar_wrk has the special property that it is + -- restartable by the scheduler, should the MVar be empty. + +newMVar :: a -> IO (MVar a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +readMVar :: MVar a -> IO a +readMVar mvar = + takeMVar mvar >>= \ value -> + putMVar mvar value >> + return value + +swapMVar :: MVar a -> a -> IO a +swapMVar mvar new = + takeMVar mvar >>= \ old -> + putMVar mvar new >> + return old + +instance Eq (MVar a) where + m1 == m2 = primSameMVar m1 m2 + + +data ThreadId + +instance Eq ThreadId where + tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0 + +instance Ord ThreadId where + compare tid1 tid2 + = let r = primCmpThreadIds tid1 tid2 + in if r < 0 then LT else if r > 0 then GT else EQ + + +forkIO :: IO a -> IO ThreadId +-- Simple version; doesn't catch exceptions in computation +-- forkIO computation +-- = primForkIO (primRunST computation) + +forkIO computation + = primForkIO ( + primCatch + (unST computation realWorld `primSeq` ()) + (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ()) + ) + where + realWorld = error "primForkIO: entered the RealWorld" ---foreign import stdcall "libHS_cbits.so" "seekFile_int64" --- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC --} -- showFloat ------------------------------------------------------------------ @@ -2194,12 +2172,6 @@ floatToDigits base x = in gen [] (r * bk) s (mUp * bk) (mDn * bk) in (map toInt (reverse rds), k) -{- --- Exponentiation with(out) a cache for the most common numbers. -expt :: Integer -> Int -> Integer -expt base n = base^n --} - -- Exponentiation with a cache for the most common numbers. minExpt = 0::Int