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, (^), (^^),
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,
- -- debugging hacks
- --,ST(..)
- ,primIntToAddr
) where
-- Standard value bindings {Prelude} ----------------------------------------
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
-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
-- etc..
--- Functions ----------------------------------------------------------------
-
-instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
-
-instance Functor ((->) a) where
- fmap = (.)
-
-- Standard Integral types --------------------------------------------------
data Int -- builtin datatype of fixed size integers
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
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 ()
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
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
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
data IOResult = IOResult deriving (Show)
-type FILE_STAR = Int -- 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 -> Int -> 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 -> Int -> IO ()
-foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Int
-
-foreign import "nHandle" "nh_argc" nh_argc :: IO Int
-foreign import "nHandle" "nh_argvb" nh_argvb :: Int -> Int -> IO Int
-foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
+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) = nh_store ptr (primCharToInt c) >> loop (incAddr ptr) cs
+ let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
+ loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
in
if isNullAddr ptr0
then error "copy_String_to_cstring: malloc failed"
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 (incAddr ptr) >>= \cs ->
- return ((primIntToChar ci) : cs)
+ return (ci : cs)
readfromhandle :: FILE_STAR -> IO String
readfromhandle 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
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)
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))
(>=) = primGeAddr
(>) = primGtAddr
-
data Word
instance Eq Word where
(>=) = primGeWord
(>) = primGtWord
-
data StablePtr a
makeStablePtr :: a -> IO (StablePtr a)
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 ------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff