From 7bc3ecec5e8c39c61413c1d00cd920ebd3bd6308 Mon Sep 17 00:00:00 2001 From: andy Date: Thu, 9 Mar 2000 06:14:39 +0000 Subject: [PATCH] [project @ 2000-03-09 06:14:38 by andy] improving the synatax and semantics of the privileged import Typical use might be: import Prelude import privileged Prelude ( IORef , unsafePerformIO ) Which means please ignore the export that comes with Prelude, and let me at compiler internal magic operations, IORef and unsafePerformIO (both are later exported by IOExt) I've also updated the stdlib files to use this (hugs only :-). --- ghc/includes/options.h | 5 ++-- ghc/interpreter/parser.y | 10 ++++---- ghc/interpreter/static.c | 61 +++++++++++++++++++++++++++++++++++----------- ghc/lib/hugs/Prelude.hs | 57 +++---------------------------------------- ghc/lib/std/Array.lhs | 11 ++++++++- ghc/lib/std/CPUTime.lhs | 8 +++++- ghc/lib/std/IO.lhs | 42 +++++++++++++++++++++++++------ ghc/lib/std/Random.lhs | 17 ++++++++++--- ghc/lib/std/Ratio.lhs | 8 ++++++ ghc/lib/std/System.lhs | 17 +++++++++++++ 10 files changed, 149 insertions(+), 87 deletions(-) diff --git a/ghc/includes/options.h b/ghc/includes/options.h index 5ed6c4e..fae3ab0 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: options.h,v $ - * $Revision: 1.18 $ - * $Date: 2000/03/06 08:42:56 $ + * $Revision: 1.19 $ + * $Date: 2000/03/09 06:14:38 $ * ------------------------------------------------------------------------*/ @@ -172,6 +172,7 @@ #undef PROVIDE_PTREQUALITY #undef PROVIDE_COERCE +#define PROVIDE_COERCE 1 #define PROVIDE_PTREQUALITY 1 /* Set to 1 to use a non-GMP implementation of integer, in the diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index dc8251c..53778f8 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.23 $ - * $Date: 2000/03/09 02:47:13 $ + * $Revision: 1.24 $ + * $Date: 2000/03/09 06:14:38 $ * ------------------------------------------------------------------------*/ %{ @@ -529,9 +529,9 @@ impDecl : IMPORT modid impspec {addQualImport($2,$2); | IMPORT QUALIFIED modid impspec {addQualImport($3,$3); $$ = gc4($3);} - | IMPORT PRIVILEGED modid {addQualImport($3,$3); - addUnqualImport($3,gc0(STAR)); - $$ = gc4($3);} + | IMPORT PRIVILEGED modid '(' imports ')' + {addUnqualImport($3,ap(STAR,$5)); + $$ = gc6($3);} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(DOTDOT);} diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 4797250..b9dae73 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.25 $ - * $Date: 2000/03/09 02:47:13 $ + * $Revision: 1.26 $ + * $Date: 2000/03/09 06:14:38 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -34,8 +34,8 @@ static List local checkSubentities Args((List,List,List,String,Text)); static List local checkExportTycon Args((List,Text,Cell,Tycon)); static List local checkExportClass Args((List,Text,Cell,Class)); static List local checkExport Args((List,Text,Cell)); -static List local checkImportEntity Args((List,Module,Cell)); -static List local resolveImportList Args((Module,Cell)); +static List local checkImportEntity Args((List,Module,Bool,Cell)); +static List local resolveImportList Args((Module,Cell,Bool)); static Void local checkImportList Args((Pair)); static Void local importEntity Args((Module,Cell)); @@ -354,15 +354,28 @@ Text textParent; { return imports; } -static List local checkImportEntity(imports,exporter,entity) +static List local checkImportEntity(imports,exporter,priv,entity) List imports; /* Accumulated list of things to import */ Module exporter; -Cell entity; { /* Entry from import list */ +Bool priv; +Cell entity; { /* Entry from import list */ List oldImports = imports; Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity)); - List es = module(exporter).exports; + List es = NIL; + if (priv) { + es = module(exporter).names; + es = dupOnto(module(exporter).tycons,es); + es = dupOnto(module(exporter).classes,es); + } else { + es = module(exporter).exports; + } + for(; nonNull(es); es=tl(es)) { - Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */ + Cell e = hd(es); /* :: Entity + | (Entity, NIL|DOTDOT) + | tycon + | class + */ if (isPair(e)) { Cell f = fst(e); if (isTycon(f)) { @@ -403,6 +416,18 @@ Cell entity; { /* Entry from import list */ if (isIdent(entity) && name(e).text == t) { imports = cons(e,imports); } + } else if (isTycon(e) && priv) { + if (tycon(e).text == t) { + imports = cons(e,imports); + return dupOnto(tycon(e).defn,imports); + } + } else if (isClass(e) && priv) { + if (cclass(e).text == t) { + imports = cons(e,imports); + return dupOnto(cclass(e).members,imports); + } + } else if (whatIs(e) == TUPLE && priv) { + // do nothing } else { internal("checkImportEntity3"); } @@ -416,9 +441,10 @@ Cell entity; { /* Entry from import list */ return imports; } -static List local resolveImportList(m,impList) +static List local resolveImportList(m,impList,priv) Module m; /* exporting module */ -Cell impList; { +Cell impList; +Bool priv; { List imports = NIL; if (DOTDOT == impList) { List es = module(m).exports; @@ -441,6 +467,7 @@ Cell impList; { } } } +#if 0 } else if (STAR == impList) { List xs; for(xs=module(m).names; nonNull(xs); xs=tl(xs)) { @@ -460,8 +487,9 @@ Cell impList; { || tycon(t).what == NEWTYPE)) imports = dupOnto(tycon(t).defn,imports); } +#endif } else { - map1Accum(checkImportEntity,imports,m,impList); + map2Accum(checkImportEntity,imports,m,priv,impList); } return imports; } @@ -483,10 +511,15 @@ Pair importSpec; { /* Somewhat inefficient - but obviously correct: * imports = importsOf("module Foo") `setDifference` hidden; */ - hidden = resolveImportList(m, snd(impList)); - imports = resolveImportList(m, DOTDOT); + hidden = resolveImportList(m, snd(impList),FALSE); + imports = resolveImportList(m, DOTDOT,FALSE); + } else if (isPair(impList) && STAR == fst(impList)) { + /* Somewhat inefficient - but obviously correct: + * imports = importsOf("module Foo") `setDifference` hidden; + */ + imports = resolveImportList(m, snd(impList),TRUE); } else { - imports = resolveImportList(m, impList); + imports = resolveImportList(m, impList,FALSE); } for(; nonNull(imports); imports=tl(imports)) { diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index be1bcc0..1937a12 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -60,7 +60,7 @@ module Prelude ( -- module Ratio, Ratio, Rational, (%), numerator, denominator, approxRational, -- Non-standard exports - IO(..), IOResult(..), Addr, StablePtr, + IO, IOResult(..), Addr, StablePtr, makeStablePtr, freeStablePtr, deRefStablePtr, Bool(False, True), @@ -102,49 +102,6 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar - , ThreadId, forkIO - , trace - - - , ST(..) - , STRef, newSTRef, readSTRef, writeSTRef - , IORef, newIORef, readIORef, writeIORef - , PrimMutableArray, PrimMutableByteArray - , RealWorld - - -- This lot really shouldn't be exported, but are needed to - -- implement various libs. - , runST , fixST, unsafeInterleaveST - , stToIO , ioToST - , unsafePerformIO - , primReallyUnsafePtrEquality - ,hugsprimCompAux,PrimArray, primNewArray,primWriteArray - ,primReadArray, primIndexArray, primSizeMutableArray - ,primSizeArray - ,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, - 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} ---------------------------------------- @@ -1658,11 +1615,9 @@ print :: Show a => a -> IO () print = putStrLn . show getChar :: IO Char -getChar = unsafeInterleaveIO ( - nh_stdin >>= \h -> +getChar = nh_stdin >>= \h -> nh_read h >>= \ci -> return (primIntToChar ci) - ) getLine :: IO String getLine = do c <- getChar @@ -1906,12 +1861,6 @@ hugsprimRunIO_toplevel m = primCatch (protect (n-1) comp) (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld)) -trace, trace_quiet :: String -> a -> a -trace s x - = trace_quiet ("trace: " ++ s) x -trace_quiet s x - = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x - unsafeInterleaveIO :: IO a -> IO a unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s)) @@ -2064,6 +2013,8 @@ forkIO computation where realWorld = error "primForkIO: entered the RealWorld" +trace_quiet s x + = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x -- showFloat ------------------------------------------------------------------ diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs index 5ff36c9..5ee94ff 100644 --- a/ghc/lib/std/Array.lhs +++ b/ghc/lib/std/Array.lhs @@ -45,6 +45,15 @@ import PrelShow import PrelArr -- Most of the hard work is done here import PrelBase #else +import Prelude +import privileged Prelude ( PrimArray + , runST + , primNewArray + , primWriteArray + , primReadArray + , primUnsafeFreezeArray + , primIndexArray + ) import Ix import List( (\\) ) #endif @@ -89,7 +98,7 @@ ixmap b f a = array b [(i, a ! f i) | i <- range b] data Array ix elt = Array (ix,ix) (PrimArray elt) array :: Ix a => (a,a) -> [(a,b)] -> Array a b -array ixs@(ix_start, ix_end) ivs = primRunST (do +array ixs@(ix_start, ix_end) ivs = runST (do { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs ; arr <- primUnsafeFreezeArray mut_arr diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index 9d7e6a7..d1d7179 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -65,6 +65,12 @@ foreign import "libHS_cbits" "clockTicks" clockTicks :: IO Int #else \begin{code} +import Prelude +import privileged Prelude ( nh_getCPUtime + , nh_getCPUprec + , unsafePerformIO + ) + getCPUTime :: IO Integer getCPUTime = do seconds <- nh_getCPUtime @@ -72,7 +78,7 @@ getCPUTime cpuTimePrecision :: Integer cpuTimePrecision - = primRunST ( + = unsafePerformIO ( do resolution <- nh_getCPUprec return (round (resolution * 1.0e+12)) ) diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index fbb5cd3..ef96cab 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -94,6 +94,32 @@ module IO ( #ifdef __HUGS__ import Ix(Ix) +import Prelude +import privileged Prelude ( IORef + , unsafePerformIO + , prelCleanupAfterRunAction + , copy_String_to_cstring + , primIntToChar + , primWriteCharOffAddr + , nullAddr + , newIORef + , writeIORef + , readIORef + , nh_close + , nh_errno + , nh_stdin + , nh_stdout + , nh_stderr + , nh_flush + , nh_open + , nh_free + , nh_read + , nh_write + , nh_filesize + , nh_iseof + ) + + #else --import PrelST import PrelBase @@ -156,7 +182,7 @@ hWaitForInput handle msecs = @hGetChar hdl@ reads the next character from handle @hdl@, blocking until a character is available. -\begin{code} +]\begin{code} hGetChar :: Handle -> IO Char hGetChar handle = do c <- mayBlockRead "hGetChar" handle fileGetc @@ -731,24 +757,24 @@ mkErr h msg stdin = Handle { name = "stdin", - file = primRunST nh_stdin, - mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + file = unsafePerformIO nh_stdin, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), mode = ReadMode } stdout = Handle { name = "stdout", - file = primRunST nh_stdout, - mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + file = unsafePerformIO nh_stdout, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), mode = WriteMode } stderr = Handle { name = "stderr", - file = primRunST nh_stderr, - mut = primRunST (newIORef (Handle_Mut { state = HOpen })), + file = unsafePerformIO nh_stderr, + mut = unsafePerformIO (newIORef (Handle_Mut { state = HOpen })), mode = WriteMode } @@ -790,7 +816,7 @@ data HState = HOpen | HSemiClosed | HClosed -- once handles appear in the list. allHandles :: IORef [Handle] -allHandles = primRunST (newIORef []) +allHandles = unsafePerformIO (newIORef []) elemWriterHandles :: FilePath -> IO Bool elemAllHandles :: FilePath -> IO Bool diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs index 0064315..889d423 100644 --- a/ghc/lib/std/Random.lhs +++ b/ghc/lib/std/Random.lhs @@ -36,10 +36,19 @@ import PrelRead ( readDec ) import PrelIOBase ( unsafePerformIO, stToIO ) import PrelArr ( MutableVar, newVar, readVar, writeVar ) import PrelReal ( toInt ) -import CPUTime ( getCPUTime ) import PrelFloat ( float2Double, double2Float ) import Time ( getClockTime, ClockTime(..) ) #endif +import CPUTime ( getCPUTime ) +import Prelude +import privileged Prelude + ( IORef + , newIORef + , readIORef + , writeIORef + , unsafePerformIO + ) + import Char ( isSpace, chr, ord ) \end{code} @@ -184,7 +193,9 @@ instance Random Float where \begin{code} #ifdef __HUGS__ mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = return (createStdGen o) +mkStdRNG o = do + ct <- getCPUTime + return (createStdGen (ct + o)) #else mkStdRNG :: Integer -> IO StdGen mkStdRNG o = do @@ -270,7 +281,7 @@ getStdGen :: IO StdGen getStdGen = readIORef theStdGen theStdGen :: IORef StdGen -theStdGen = primRunST (newIORef (createStdGen 0)) +theStdGen = unsafePerformIO (newIORef (createStdGen 0)) #else diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs index f7593ab..cd27634 100644 --- a/ghc/lib/std/Ratio.lhs +++ b/ghc/lib/std/Ratio.lhs @@ -80,8 +80,16 @@ approxRational rat eps = simplest (rat-eps) (rat+eps) nd'' = simplest' d' r' d r n'' = numerator nd'' d'' = denominator nd'' + \end{code} +#else + +\begin{code} +-- Hugs already has this functionally inside its prelude +\end{code} #endif + + diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index 41373d1..ab4f9d9 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -188,6 +188,23 @@ unpackProgName argv -- -- Suitable for use with Hugs 98 ----------------------------------------------------------------------------- +import Prelude +import privileged Prelude ( primGetRawArgs + , primGetEnv + , prelCleanupAfterRunAction + , copy_String_to_cstring + , readIORef + , nh_stderr + , nh_stdout + , nh_stdin + , nh_exitwith + , nh_flush + , nh_close + , nh_system + , nh_free + , nh_getPID + ) + data ExitCode = ExitSuccess | ExitFailure Int deriving (Eq, Ord, Read, Show) -- 1.7.10.4