From: sewardj Date: Mon, 22 Nov 1999 16:00:26 +0000 (+0000) Subject: [project @ 1999-11-22 16:00:21 by sewardj] X-Git-Tag: Approximately_9120_patches~5525 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e566a694f59e5b7b020104ea4a24f465d4a2cbe3;p=ghc-hetmet.git [project @ 1999-11-22 16:00:21 by sewardj] Enforce multiple reader, single writer semantics for Handles. --- diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 30483d0..5a2fbd6 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * 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" @@ -1509,7 +1509,7 @@ Void evalExp() { /* compile and run input expression */ 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: diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 33145a9..406d775 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -119,7 +119,7 @@ module Prelude ( ,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, @@ -135,11 +135,7 @@ module Prelude ( primAddrToInt, primIntToAddr, primDoubleToFloat, primFloatToDouble, - -- debugging hacks - --,ST(..) - --,primIntToAddr - --,primGetArgc - --,primGetArgv + ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1829,11 +1825,29 @@ 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 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 diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 7ac9076..4df6710 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * 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" @@ -475,7 +475,7 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ /* static(tidyInfix) */ nameNegate = linkName("negate"); /* user interface */ - nameRunIO = linkName("primRunIO"); + nameRunIO = linkName("primRunIO_hugs_toplevel"); namePrint = linkName("print"); /* desugar */ nameOtherwise = linkName("otherwise"); diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 33145a9..406d775 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -119,7 +119,7 @@ module Prelude ( ,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, @@ -135,11 +135,7 @@ module Prelude ( primAddrToInt, primIntToAddr, primDoubleToFloat, primFloatToDouble, - -- debugging hacks - --,ST(..) - --,primIntToAddr - --,primGetArgc - --,primGetArgv + ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -1829,11 +1825,29 @@ 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 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 diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 5fca791..0107b7d 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -699,6 +699,7 @@ readLn = do l <- getLine \begin{code} import Ix(Ix) +import Monad(when) unimp :: String -> a unimp s = error ("IO library: function not implemented: " ++ s) @@ -718,6 +719,7 @@ data Handle data Handle_Mut = Handle_Mut { state :: HState } + deriving Show set_state :: Handle -> HState -> IO () set_state hdl new_state @@ -728,7 +730,9 @@ get_state hdl 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) @@ -761,7 +765,7 @@ instance Eq Handle where h1 == h2 = file h1 == file h2 instance Show Handle where - showsPrec _ h = showString ("<<" ++ name h ++ ">>") + showsPrec _ h = showString ("`" ++ name h ++ "'") data HandlePosn = HandlePosn @@ -779,23 +783,105 @@ data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd 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 @@ -808,11 +894,13 @@ openFile f mode 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 @@ -979,6 +1067,7 @@ bracket_ before after m = do case rs of Right r -> return r Left e -> ioError e + -- TODO: Hugs/slurpFile slurpFile = unimp "IO.slurpFile" \end{code} diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index d3ad1af..ba31873 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -214,12 +214,17 @@ fromExitCode :: ExitCode -> Int 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