Commit 4fb94ae5 authored by simonmar's avatar simonmar
Browse files

[project @ 2001-06-28 14:15:04 by simonmar]

First cut of the Haskell Core Libraries
=======================================

NOTE: it's not meant to be a working snapshot.  The code is just here
to look at and so the NHC/Hugs guys can start playing around with it.

There is no build system.  For GHC, the libraries tree is intended to
be grafted onto an existing fptools/ tree, and the Makefile in
libraries/core is a quick hack for that setup.  This won't work at the
moment without the other changes needed in fptools/ghc, which I
haven't committed because they'll cause breakage.  However, with the
changes required these sources build a working Prelude and libraries.

The layout mostly follows the one we agreed on, with one or two minor
changes; in particular the Data/Array layout probably isn't final
(there are several choices here).

The document is in libraries/core/doc as promised.

The cbits stuff is just a copy of ghc/lib/std/cbits and has
GHC-specific stuff in it.  We should really separate the
compiler-specific C support from any compiler-independent C support
there might be.

Don't pay too much attention to the portability or stability status
indicated in the header of each source file at the moment - I haven't
gone through to make sure they're all consistent and make sense.

I'm using non-literate source outside of GHC/.  Hope that's ok with
everyone.

We need to discuss how the build system is going to work...
parents
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
--
-- A common interface to a collection of useful concurrency
-- abstractions.
--
-----------------------------------------------------------------------------
module Control.Concurrent
( module Control.Concurrent.Chan
, module Control.Concurrent.CVar
, module Control.Concurrent.MVar
, module Control.Concurrent.QSem
, module Control.Concurrent.QSemN
, module Control.Concurrent.SampleVar
#ifdef __HUGS__
, forkIO -- :: IO () -> IO ()
#elif defined(__GLASGOW_HASKELL__)
, ThreadId
-- Forking and suchlike
, myThreadId -- :: IO ThreadId
, killThread -- :: ThreadId -> IO ()
, throwTo -- :: ThreadId -> Exception -> IO ()
#endif
, par -- :: a -> b -> b
, seq -- :: a -> b -> b
#ifdef __GLASGOW_HASKELL__
, fork -- :: a -> b -> b
#endif
, yield -- :: IO ()
#ifdef __GLASGOW_HASKELL__
, threadDelay -- :: Int -> IO ()
, threadWaitRead -- :: Int -> IO ()
, threadWaitWrite -- :: Int -> IO ()
#endif
-- merging of streams
, mergeIO -- :: [a] -> [a] -> IO [a]
, nmergeIO -- :: [[a]] -> IO [a]
) where
import Prelude
import Control.Exception as Exception
#ifdef __GLASGOW_HASKELL__
import GHC.Conc
import GHC.TopHandler ( reportStackOverflow, reportError )
import GHC.IOBase ( IO(..) )
import GHC.IOBase ( unsafePerformIO , unsafeInterleaveIO )
import GHC.Base ( fork# )
import GHC.Prim ( Addr#, unsafeCoerce# )
#endif
#ifdef __HUGS__
import IOExts ( unsafeInterleaveIO, unsafePerformIO )
import ConcBase
#endif
import Control.Concurrent.MVar
import Control.Concurrent.CVar
import Control.Concurrent.Chan
import Control.Concurrent.QSem
import Control.Concurrent.QSemN
import Control.Concurrent.SampleVar
#ifdef __GLASGOW_HASKELL__
infixr 0 `fork`
#endif
-- Thread Ids, specifically the instances of Eq and Ord for these things.
-- The ThreadId type itself is defined in std/PrelConc.lhs.
-- Rather than define a new primitve, we use a little helper function
-- cmp_thread in the RTS.
#ifdef __GLASGOW_HASKELL__
foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
-- Returns -1, 0, 1
cmpThread :: ThreadId -> ThreadId -> Ordering
cmpThread (ThreadId t1) (ThreadId t2) =
case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
-1 -> LT
0 -> EQ
_ -> GT -- must be 1
instance Eq ThreadId where
t1 == t2 =
case t1 `cmpThread` t2 of
EQ -> True
_ -> False
instance Ord ThreadId where
compare = cmpThread
forkIO :: IO () -> IO ThreadId
forkIO action = IO $ \ s ->
case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
where
action_plus = Exception.catch action childHandler
childHandler :: Exception -> IO ()
childHandler err = Exception.catch (real_handler err) childHandler
real_handler :: Exception -> IO ()
real_handler ex =
case ex of
-- ignore thread GC and killThread exceptions:
BlockedOnDeadMVar -> return ()
AsyncException ThreadKilled -> return ()
-- report all others:
AsyncException StackOverflow -> reportStackOverflow False
ErrorCall s -> reportError False s
other -> reportError False (showsPrec 0 other "\n")
{-# INLINE fork #-}
fork :: a -> b -> b
fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
#endif /* __GLASGOW_HASKELL__ */
max_buff_size :: Int
max_buff_size = 1
mergeIO :: [a] -> [a] -> IO [a]
nmergeIO :: [[a]] -> IO [a]
mergeIO ls rs
= newEmptyMVar >>= \ tail_node ->
newMVar tail_node >>= \ tail_list ->
newQSem max_buff_size >>= \ e ->
newMVar 2 >>= \ branches_running ->
let
buff = (tail_list,e)
in
forkIO (suckIO branches_running buff ls) >>
forkIO (suckIO branches_running buff rs) >>
takeMVar tail_node >>= \ val ->
signalQSem e >>
return val
type Buffer a
= (MVar (MVar [a]), QSem)
suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
suckIO branches_running buff@(tail_list,e) vs
= case vs of
[] -> takeMVar branches_running >>= \ val ->
if val == 1 then
takeMVar tail_list >>= \ node ->
putMVar node [] >>
putMVar tail_list node
else
putMVar branches_running (val-1)
(x:xs) ->
waitQSem e >>
takeMVar tail_list >>= \ node ->
newEmptyMVar >>= \ next_node ->
unsafeInterleaveIO (
takeMVar next_node >>= \ y ->
signalQSem e >>
return y) >>= \ next_node_val ->
putMVar node (x:next_node_val) >>
putMVar tail_list next_node >>
suckIO branches_running buff xs
nmergeIO lss
= let
len = length lss
in
newEmptyMVar >>= \ tail_node ->
newMVar tail_node >>= \ tail_list ->
newQSem max_buff_size >>= \ e ->
newMVar len >>= \ branches_running ->
let
buff = (tail_list,e)
in
mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
takeMVar tail_node >>= \ val ->
signalQSem e >>
return val
where
mapIO f xs = sequence (map f xs)
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent.CVar
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: CVar.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
--
-- Channel variables are one-element channels.
--
-----------------------------------------------------------------------------
module Control.Concurrent.CVar
( -- abstract
CVar
, newCVar -- :: IO (CVar a)
, writeCVar -- :: CVar a -> a -> IO ()
, readCVar -- :: CVar a -> IO a
) where
import Prelude
import Control.Concurrent.MVar
-- @MVars@ provide the basic mechanisms for synchronising access to a
-- shared resource. @CVars@, or channel variables, provide an abstraction
-- that guarantee that the producer is not allowed to run riot, but
-- enforces the interleaved access to the channel variable,i.e., a
-- producer is forced to wait up for a consumer to remove the previous
-- value before it can deposit a new one in the @CVar@.
data CVar a
= CVar (MVar a) -- prod -> cons
(MVar ()) -- cons -> prod
newCVar :: IO (CVar a)
newCVar
= newEmptyMVar >>= \ datum ->
newMVar () >>= \ ack ->
return (CVar datum ack)
writeCVar :: CVar a -> a -> IO ()
writeCVar (CVar datum ack) val
= takeMVar ack >>
putMVar datum val >>
return ()
readCVar :: CVar a -> IO a
readCVar (CVar datum ack)
= takeMVar datum >>= \ val ->
putMVar ack () >>
return val
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent.Chan
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: Chan.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
--
-- Standard, unbounded channel abstraction.
--
-----------------------------------------------------------------------------
module Control.Concurrent.Chan
( Chan -- abstract
-- creator
, newChan -- :: IO (Chan a)
-- operators
, writeChan -- :: Chan a -> a -> IO ()
, readChan -- :: Chan a -> IO a
, dupChan -- :: Chan a -> IO (Chan a)
, unGetChan -- :: Chan a -> a -> IO ()
, isEmptyChan -- :: Chan a -> IO Bool
-- stream interface
, getChanContents -- :: Chan a -> IO [a]
, writeList2Chan -- :: Chan a -> [a] -> IO ()
) where
import Prelude
import System.IO.Unsafe ( unsafeInterleaveIO )
import Control.Concurrent.MVar
-- A channel is represented by two @MVar@s keeping track of the two ends
-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
-- are used to handle consumers trying to read from an empty channel.
data Chan a
= Chan (MVar (Stream a))
(MVar (Stream a))
type Stream a = MVar (ChItem a)
data ChItem a = ChItem a (Stream a)
-- See the Concurrent Haskell paper for a diagram explaining the
-- how the different channel operations proceed.
-- @newChan@ sets up the read and write end of a channel by initialising
-- these two @MVar@s with an empty @MVar@.
newChan :: IO (Chan a)
newChan = do
hole <- newEmptyMVar
read <- newMVar hole
write <- newMVar hole
return (Chan read write)
-- To put an element on a channel, a new hole at the write end is created.
-- What was previously the empty @MVar@ at the back of the channel is then
-- filled in with a new stream element holding the entered value and the
-- new hole.
writeChan :: Chan a -> a -> IO ()
writeChan (Chan _read write) val = do
new_hole <- newEmptyMVar
modifyMVar_ write $ \old_hole -> do
putMVar old_hole (ChItem val new_hole)
return new_hole
readChan :: Chan a -> IO a
readChan (Chan read _write) = do
modifyMVar read $ \read_end -> do
(ChItem val new_read_end) <- readMVar read_end
-- Use readMVar here, not takeMVar,
-- else dupChan doesn't work
return (new_read_end, val)
dupChan :: Chan a -> IO (Chan a)
dupChan (Chan _read write) = do
hole <- readMVar write
new_read <- newMVar hole
return (Chan new_read write)
unGetChan :: Chan a -> a -> IO ()
unGetChan (Chan read _write) val = do
new_read_end <- newEmptyMVar
modifyMVar_ read $ \read_end -> do
putMVar new_read_end (ChItem val read_end)
return new_read_end
isEmptyChan :: Chan a -> IO Bool
isEmptyChan (Chan read write) = do
withMVar read $ \r -> do
w <- readMVar write
let eq = r == w
eq `seq` return eq
-- Operators for interfacing with functional streams.
getChanContents :: Chan a -> IO [a]
getChanContents ch
= unsafeInterleaveIO (do
x <- readChan ch
xs <- getChanContents ch
return (x:xs)
)
-------------
writeList2Chan :: Chan a -> [a] -> IO ()
writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent.MVar
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: MVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
--
-- MVars: Synchronising variables
--
-----------------------------------------------------------------------------
module Control.Concurrent.MVar
( MVar -- abstract
, newEmptyMVar -- :: IO (MVar a)
, newMVar -- :: a -> IO (MVar a)
, takeMVar -- :: MVar a -> IO a
, putMVar -- :: MVar a -> a -> IO ()
, readMVar -- :: MVar a -> IO a
, swapMVar -- :: MVar a -> a -> IO a
, tryTakeMVar -- :: MVar a -> IO (Maybe a)
, tryPutMVar -- :: MVar a -> a -> IO Bool
, isEmptyMVar -- :: MVar a -> IO Bool
, withMVar -- :: MVar a -> (a -> IO b) -> IO b
, modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
, modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
) where
#ifdef __HUGS__
import ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar,
readMVar, swapMVar,
)
import Prelude hiding( catch )
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
)
#endif
import Control.Exception as Exception
#ifdef __HUGS__
-- This is as close as Hugs gets to providing throw
throw :: Exception -> IO a
throw = throwIO
#endif
#ifdef __GLASGOW_HASKELL__
readMVar :: MVar a -> IO a
readMVar m =
block $ do
a <- takeMVar m
putMVar m a
return a
swapMVar :: MVar a -> a -> IO a
swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
#endif
-- put back the same value, return something
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar m io =
block $ do
a <- takeMVar m
b <- Exception.catch (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a
return b
-- put back a new value, return ()
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io =
block $ do
a <- takeMVar m
a' <- Exception.catch (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a'
-- put back a new value, return something
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io =
block $ do
a <- takeMVar m
(a',b) <- Exception.catch (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a'
return b
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent.QSem
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: QSem.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
--
-- General semaphores
--
-----------------------------------------------------------------------------
module Control.Concurrent.QSem
( QSem, -- abstract
newQSem, -- :: Int -> IO QSem
waitQSem, -- :: QSem -> IO ()
signalQSem -- :: QSem -> IO ()
) where
import Control.Concurrent.MVar
-- General semaphores are also implemented readily in terms of shared
-- @MVar@s, only have to catch the case when the semaphore is tried
-- waited on when it is empty (==0). Implement this in the same way as
-- shared variables are implemented - maintaining a list of @MVar@s
-- representing threads currently waiting. The counter is a shared
-- variable, ensuring the mutual exclusion on its access.
newtype QSem = QSem (MVar (Int, [MVar ()]))
newQSem :: Int -> IO QSem
newQSem init = do
sem <- newMVar (init,[])
return (QSem sem)
waitQSem :: QSem -> IO ()
waitQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
putMVar sem (avail-1,[])
else do
block <- newEmptyMVar
{-
Stuff the reader at the back of the queue,
so as to preserve waiting order. A signalling
process then only have to pick the MVar at the
front of the blocked list.
The version of waitQSem given in the paper could
lead to starvation.
-}
putMVar sem (0, blocked++[block])
takeMVar block
signalQSem :: QSem -> IO ()
signalQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem
case blocked of
[] -> putMVar sem (avail+1,[])
(block:blocked') -> do
putMVar sem (0,blocked')
putMVar block ()
-----------------------------------------------------------------------------
--
-- Module : Control.Concurrent.QSemN
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- $Id: QSemN.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
--
-- Quantity semaphores
--
-----------------------------------------------------------------------------
module Control.Concurrent.QSemN
( QSemN, -- abstract
newQSemN, -- :: Int -> IO QSemN
waitQSemN, -- :: QSemN -> Int -> IO ()
signalQSemN -- :: QSemN -> Int -> IO ()
) where
import Prelude
import Control.Concurrent.MVar
newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
newQSemN :: Int -> IO QSemN
newQSemN init = do
sem <- newMVar (init,[])
return (QSemN sem)
waitQSemN :: QSemN -> Int -> IO ()
waitQSemN (QSemN sem) sz = do
(avail,blocked) <- takeMVar sem -- gain ex. access
if (avail - sz) >= 0 then
-- discharging 'sz' still leaves the semaphore
-- in an 'unblocked' state.
putMVar sem (avail-sz,[])
else do
block <- newEmptyMVar
putMVar sem (avail, blocked++[(sz,block)])
takeMVar block
signalQSemN :: QSemN -> Int -> IO ()
signalQSemN (QSemN sem) n = do
(avail,blocked) <- takeMVar sem
(avail',blocked') <- free (avail+n) blocked
putMVar sem (avail',blocked')
where
free avail [] = return (avail,[])
free avail ((req,block):blocked)
| avail >= req = do
putMVar block ()
free (avail-req) blocked
| otherwise = do
(avail',blocked') <- free avail blocked
return (avail',(req