X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fhugs%2FPrelude.hs;h=69c9db635f1f81a2779d47f5c4914eb7808c1bea;hb=618348854155e48b3abb64809065601c586d0553;hp=1533c07456816e0c8b268002ad4cbf9d63750162;hpb=36c0b5de339d1153c76c961b7e6829321d286d06;p=ghc-hetmet.git diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 1533c07..69c9db6 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -103,20 +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, - nullAddr, incAddr, isNullAddr, - -- debugging hacks - --,ST(..) - --,primIntToAddr - --,primGetArgc - --,primGetArgv + 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, + ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1696,21 +1715,29 @@ data IOResult = IOResult deriving (Show) 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_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 @@ -1779,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) @@ -1798,19 +1824,42 @@ instance Monad (ST s) where 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 "primRunIO: entered the RealWorld" - protect :: () -> () - protect comp - = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) + composite_action + = do writeIORef prelCleanupAfterRunAction Nothing + m + cleanup_handles <- readIORef prelCleanupAfterRunAction + case cleanup_handles of + Nothing -> return () + Just xx -> xx -trace :: String -> a -> a + 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)) @@ -1839,7 +1888,6 @@ instance Ord Addr where (>=) = primGeAddr (>) = primGtAddr - data Word instance Eq Word where @@ -1852,7 +1900,6 @@ instance Ord Word where (>=) = primGeWord (>) = primGtWord - data StablePtr a makeStablePtr :: a -> IO (StablePtr a) @@ -1866,10 +1913,109 @@ 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 + + +------------------------------------------------------------------------------ +-- ThreadId, MVar, concurrency stuff ----------------------------------------- +------------------------------------------------------------------------------ + +data MVar a + +newEmptyMVar :: IO (MVar a) +newEmptyMVar = primNewEmptyMVar + +putMVar :: MVar a -> a -> IO () +putMVar = primPutMVar + +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" -- showFloat ------------------------------------------------------------------