Enforce multiple reader, single writer semantics for Handles.
* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.14 $
- * $Date: 1999/11/22 14:39:43 $
+ * $Revision: 1.15 $
+ * $Date: 1999/11/22 16:00:21 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
switch (status) {
case Deadlock:
case AllBlocked: /* I don't understand the distinction - ADR */
- printf("{Deadlock -- might be circular data dependencies}");
+ printf("{Deadlock or Blackhole}");
if (doRevertCAFs) RevertCAFs();
break;
case Interrupted:
,unsafeInterleaveIO,nh_write,primCharToInt,
nullAddr, incAddr, isNullAddr,
nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
- nh_getCPUtime, nh_getCPUprec,
+ nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
Word,
primGtWord, primGeWord, primEqWord, primNeWord,
primAddrToInt, primIntToAddr,
primDoubleToFloat, primFloatToDouble,
- -- debugging hacks
- --,ST(..)
- --,primIntToAddr
- --,primGetArgc
- --,primGetArgv
+
) where
-- Standard value bindings {Prelude} ----------------------------------------
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 5 (fst (unST m realWorld))
+primRunIO_hugs_toplevel :: IO () -> ()
+primRunIO_hugs_toplevel m
+ = protect 5 (fst (unST composite_action realWorld))
where
+ 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
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/19 15:42:07 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/22 16:00:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
/* static(tidyInfix) */
nameNegate = linkName("negate");
/* user interface */
- nameRunIO = linkName("primRunIO");
+ nameRunIO = linkName("primRunIO_hugs_toplevel");
namePrint = linkName("print");
/* desugar */
nameOtherwise = linkName("otherwise");
,unsafeInterleaveIO,nh_write,primCharToInt,
nullAddr, incAddr, isNullAddr,
nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
- nh_getCPUtime, nh_getCPUprec,
+ nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
Word,
primGtWord, primGeWord, primEqWord, primNeWord,
primAddrToInt, primIntToAddr,
primDoubleToFloat, primFloatToDouble,
- -- debugging hacks
- --,ST(..)
- --,primIntToAddr
- --,primGetArgc
- --,primGetArgv
+
) where
-- Standard value bindings {Prelude} ----------------------------------------
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 5 (fst (unST m realWorld))
+primRunIO_hugs_toplevel :: IO () -> ()
+primRunIO_hugs_toplevel m
+ = protect 5 (fst (unST composite_action realWorld))
where
+ 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
\begin{code}
import Ix(Ix)
+import Monad(when)
unimp :: String -> a
unimp s = error ("IO library: function not implemented: " ++ s)
data Handle_Mut
= Handle_Mut { state :: HState
}
+ deriving Show
set_state :: Handle -> HState -> IO ()
set_state hdl new_state
mkErr :: Handle -> String -> IO a
mkErr h msg
- = do nh_close (file h)
+ = do mut <- readIORef (mut h)
+ when (state mut /= HClosed)
+ (nh_close (file h) >> set_state h HClosed)
dummy <- nh_errno
ioError (IOError msg)
h1 == h2 = file h1 == file h2
instance Show Handle where
- showsPrec _ h = showString ("<<" ++ name h ++ ">>")
+ showsPrec _ h = showString ("`" ++ name h ++ "'")
data HandlePosn
= HandlePosn
deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
data HState = HOpen | HSemiClosed | HClosed
- deriving Eq
+ deriving (Show, Eq)
+
+
+-- A global variable holding a list of all open handles.
+-- Each handle is present as many times as it has been opened.
+-- Any given file is allowed to have _either_ one writeable handle
+-- or many readable handles in this list. The list is used to
+-- enforce single-writer multiple reader semantics. It also
+-- provides a list of handles for System.exitWith to flush and
+-- close. In order not to have to put all this stuff in the
+-- Prelude, System.exitWith merely runs prelExitWithAction,
+-- which is originally Nothing, but which we set to Just ...
+-- once handles appear in the list.
+
+allHandles :: IORef [Handle]
+allHandles = primRunST (newIORef [])
+
+elemWriterHandles :: FilePath -> IO Bool
+elemAllHandles :: FilePath -> IO Bool
+addHandle :: Handle -> IO ()
+delHandle :: Handle -> IO ()
+cleanupHandles :: IO ()
+
+cleanupHandles
+ = do hdls <- readIORef allHandles
+ mapM_ cleanupHandle hdls
+ where
+ cleanupHandle h
+ | mode h == ReadMode
+ = nh_close (file h)
+ >> nh_errno >>= \_ -> return ()
+ | otherwise
+ = nh_flush (file h) >> nh_close (file h)
+ >> nh_errno >>= \_ -> return ()
+
+elemWriterHandles fname
+ = do hdls <- readIORef allHandles
+ let hdls_w = filter ((/= ReadMode).mode) hdls
+ return (fname `elem` (map name hdls_w))
+
+elemAllHandles fname
+ = do hdls <- readIORef allHandles
+ return (fname `elem` (map name hdls))
+
+addHandle hdl
+ = do cleanup_action <- readIORef prelCleanupAfterRunAction
+ case cleanup_action of
+ Nothing
+ -> writeIORef prelCleanupAfterRunAction (Just cleanupHandles)
+ Just xx
+ -> return ()
+ hdls <- readIORef allHandles
+ writeIORef allHandles (hdl : hdls)
+
+delHandle hdl
+ = do hdls <- readIORef allHandles
+ let hdls' = takeWhile (/= hdl) hdls
+ ++ drop 1 (dropWhile (/= hdl) hdls)
+ writeIORef allHandles hdls'
+
+
openFile :: FilePath -> IOMode -> IO Handle
openFile f mode
+
+ | null f
+ = (ioError.IOError) "openFile: empty file name"
+
+ | mode == ReadMode
+ = do not_ok <- elemWriterHandles f
+ if not_ok
+ then (ioError.IOError)
+ ("openFile: `" ++ f ++ "' in " ++ show mode
+ ++ ": is already open for writing")
+ else openFile_main f mode
+
+ | mode /= ReadMode
+ = do not_ok <- elemAllHandles f
+ if not_ok
+ then (ioError.IOError)
+ ("openFile: `" ++ f ++ "' in " ++ show mode
+ ++ ": is already open for reading or writing")
+ else openFile_main f mode
+
+ | otherwise
+ = openFile_main f mode
+
+openFile_main f mode
= copy_String_to_cstring f >>= \nameptr ->
nh_open nameptr (mode2num mode) >>= \fh ->
nh_free nameptr >>
if fh == nULL
then (ioError.IOError)
("openFile: can't open <<" ++ f ++ ">> in " ++ show mode)
- else do r <- newIORef (Handle_Mut { state = HOpen })
- return (Handle {
- name = f,
- file = fh,
- mut = r,
- mode = mode
- })
+ else do r <- newIORef (Handle_Mut { state = HOpen })
+ let hdl = Handle { name = f, file = fh,
+ mut = r, mode = mode }
+ addHandle hdl
+ return hdl
where
mode2num :: IOMode -> Int
mode2num ReadMode = 0
hClose :: Handle -> IO ()
hClose h
= do mut <- readIORef (mut h)
+ putStrLn ( "hClose: state is " ++ show mut)
if state mut == HClosed
then mkErr h
("hClose on closed handle " ++ show h)
else
do set_state h HClosed
+ delHandle h
nh_close (file h)
err <- nh_errno
if err == 0
case rs of
Right r -> return r
Left e -> ioError e
+
-- TODO: Hugs/slurpFile
slurpFile = unimp "IO.slurpFile"
\end{code}
fromExitCode ExitSuccess = 0
fromExitCode (ExitFailure n) = n
--- Note. exitWith is supposed to flush and close all open or
--- semi-open handles. The code below doesn't do that --
--- we'd have to keep a list of them somewhere.
+-- see comment in Prelude.hs near primRunIO_hugs_toplevel
exitWith :: ExitCode -> IO a
exitWith c
- = do nh_exitwith (fromExitCode c)
+ = do cleanup_action <- readIORef prelExitWithAction
+ case cleanup_action of
+ Just xx -> xx
+ Nothing -> return ()
+ nh_stderr >>= nh_flush
+ nh_stdout >>= nh_flush
+ nh_stdin >>= nh_close
+ nh_exitwith (fromExitCode c)
(ioError.IOError) "System.exitWith: should not return"
system :: String -> IO ExitCode
projects / ghc-hetmet.git / commitdiff