X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fhugs%2FPrelude.hs;h=1937a12c38a32875c9244897a0a6a622f813ba0f;hb=7bc3ecec5e8c39c61413c1d00cd920ebd3bd6308;hp=940b1ad25cf0115526157b519b984bc3713b214d;hpb=140df6036ba2b57f9869e3ac96b0b00c09e85b7a;p=ghc-hetmet.git diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 940b1ad..1937a12 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -4,7 +4,7 @@ __ __ __ __ ____ ___ _______________________________________________ ||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999 ||---|| ___|| World Wide Web: http://haskell.org/hugs || || Report bugs to: hugs-bugs@haskell.org -|| || Version: January 1999 _______________________________________________ +|| || Version: STG Hugs _______________________________________________ This is the Hugs 98 Standard Prelude, based very closely on the Standard Prelude for Haskell 98. @@ -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), @@ -84,8 +84,7 @@ module Prelude ( Real(toRational), -- Integral(quot, rem, div, mod, quotRem, divMod, toInteger), Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt), --- Fractional((/), recip, fromRational), - Fractional((/), recip, fromRational, fromDouble), + Fractional((/), recip, fromRational), fromDouble, Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), RealFrac(properFraction, truncate, round, ceiling, floor), @@ -103,40 +102,6 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar - , ThreadId, forkIO - ,trace - - , Ref, newRef, readRef, writeRef - - -- Arrrggghhh!!! Help! Help! Help! - -- What?! Prelude.hs doesn't even _define_ most of these things! - ,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, - nullAddr, incAddr, isNullAddr, - - 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 - --,primGetArgc - --,primGetArgv ) where -- Standard value bindings {Prelude} ---------------------------------------- @@ -228,13 +193,13 @@ class (Num a) => Fractional a where (/) :: a -> a -> a recip :: a -> a fromRational :: Rational -> a - fromDouble :: Double -> a -- Minimal complete definition: fromRational and ((/) or recip) recip x = 1 / x - fromDouble = fromRational . toRational x / y = x * recip y +fromDouble :: Fractional a => Double -> a +fromDouble n = fromRational (toRational n) class (Fractional a) => Floating a where pi :: a @@ -371,7 +336,9 @@ class Enum a where -- Minimal complete definition: toEnum, fromEnum succ = toEnum . (1+) . fromEnum pred = toEnum . subtract 1 . fromEnum + enumFrom x = map toEnum [ fromEnum x .. ] enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ] + enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ] enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ] -- Read and Show classes ------------------------------------------------------ @@ -631,7 +598,7 @@ instance Ord a => Ord [a] where compare [] (_:_) = LT compare [] [] = EQ compare (_:_) [] = GT - compare (x:xs) (y:ys) = primCompAux x y (compare xs ys) + compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys) instance Functor [] where fmap = map @@ -850,13 +817,10 @@ realFloatToRational x = (m%1)*(b%1)^^n instance Fractional Float where (/) = primDivideFloat fromRational = rationalToRealFloat - fromDouble = primDoubleToFloat - instance Fractional Double where (/) = primDivideDouble fromRational = rationalToRealFloat - fromDouble x = x rationalToRealFloat x = x' where x' = f e @@ -1038,7 +1002,6 @@ instance Integral a => Fractional (Ratio a) where (x:%y) / (x':%y') = (x*y') % (y*x') recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x fromRational (x:%y) = fromInteger x :% fromInteger y - fromDouble = doubleToRatio -- Hugs optimises code of the form fromRational (doubleToRatio x) doubleToRatio :: Integral a => Double -> Ratio a @@ -1336,8 +1299,8 @@ showString = (++) showParen :: Bool -> ShowS -> ShowS showParen b p = if b then showChar '(' . p . showChar ')' else p -showField :: Show a => String -> a -> ShowS -showField m v = showString m . showChar '=' . shows v +hugsprimShowField :: Show a => String -> a -> ShowS +hugsprimShowField m v = showString m . showChar '=' . shows v readParen :: Bool -> ReadS a -> ReadS a readParen b g = if b then mandatory else optional @@ -1347,10 +1310,10 @@ readParen b g = if b then mandatory else optional (")",u) <- lex t ] -readField :: Read a => String -> ReadS a -readField m s0 = [ r | (t, s1) <- lex s0, t == m, - ("=",s2) <- lex s1, - r <- reads s2 ] +hugsprimReadField :: Read a => String -> ReadS a +hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m, + ("=",s2) <- lex s1, + r <- reads s2 ] lex :: ReadS String lex "" = [("","")] @@ -1544,48 +1507,61 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, -- Hooks for primitives: ----------------------------------------------------- -- Do not mess with these! -primCompAux :: Ord a => a -> a -> Ordering -> Ordering -primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT +hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering +hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT + +hugsprimEqChar :: Char -> Char -> Bool +hugsprimEqChar c1 c2 = primEqChar c1 c2 -primPmInt :: Num a => Int -> a -> Bool -primPmInt n x = fromInt n == x +hugsprimPmInt :: Num a => Int -> a -> Bool +hugsprimPmInt n x = fromInt n == x -primPmInteger :: Num a => Integer -> a -> Bool -primPmInteger n x = fromInteger n == x +hugsprimPmInteger :: Num a => Integer -> a -> Bool +hugsprimPmInteger n x = fromInteger n == x -primPmDouble :: Fractional a => Double -> a -> Bool -primPmDouble n x = fromDouble n == x +hugsprimPmDouble :: Fractional a => Double -> a -> Bool +hugsprimPmDouble n x = fromDouble n == x -- ToDo: make the message more informative. -primPmFail :: a -primPmFail = error "Pattern Match Failure" +hugsprimPmFail :: a +hugsprimPmFail = error "Pattern Match Failure" -- used in desugaring Foreign functions -primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a -primMkIO = ST - -primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr -primCreateAdjThunk fun typestr callconv +-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created +-- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value. +-- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs +-- contains a version used in combined mode. That version takes care of +-- switching between the GHC and Hugs IO representations, which are different. +hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a +hugsprimMkIO = IO + +hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +hugsprimCreateAdjThunk fun typestr callconv = do sp <- makeStablePtr fun p <- copy_String_to_cstring typestr -- is never freed a <- primCreateAdjThunkARCH sp p callconv return a -- The following primitives are only needed if (n+k) patterns are enabled: -primPmNpk :: Integral a => Int -> a -> Maybe a -primPmNpk n x = if n'<=x then Just (x-n') else Nothing - where n' = fromInt n +hugsprimPmSub :: Integral a => Int -> a -> a +hugsprimPmSub n x = x - fromInt n + +hugsprimPmFromInteger :: Integral a => Integer -> a +hugsprimPmFromInteger = fromIntegral + +hugsprimPmSubtract :: Integral a => a -> a -> a +hugsprimPmSubtract x y = x - y -primPmSub :: Integral a => Int -> a -> a -primPmSub n x = x - fromInt n +hugsprimPmLe :: Integral a => a -> a -> Bool +hugsprimPmLe x y = x <= y -- Unpack strings generated by the Hugs code generator. -- Strings can contain \0 provided they're coded right. -- -- ToDo: change this (and Hugs code generator) to use ByteArrays -primUnpackString :: Addr -> String -primUnpackString a = unpack 0 +hugsprimUnpackString :: Addr -> String +hugsprimUnpackString a = unpack 0 where -- The following decoding is based on evalString in the old machine.c unpack i @@ -1618,7 +1594,7 @@ userError s = primRaise (ErrorCall s) catch :: IO a -> (IOError -> IO a) -> IO a catch m k - = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s) + = IO (\s -> unIO m s `primCatch` \ err -> unIO (k (e2ioe err)) s) where e2ioe (IOExcept s) = IOError s e2ioe other = IOError (show other) @@ -1639,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 @@ -1716,21 +1690,29 @@ data IOResult = IOResult deriving (Show) 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_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 @@ -1784,30 +1766,31 @@ primGetEnv v nh_getenv ptr >>= \ptr2 -> nh_free ptr >> if isNullAddr ptr2 - then return [] + then ioError (IOError "getEnv failed") else copy_cstring_to_String ptr2 >>= \result -> return result ------------------------------------------------------------------------------ --- ST, IO -------------------------------------------------------------------- +-- ST ------------------------------------------------------------------------ ------------------------------------------------------------------------------ newtype ST s a = ST (s -> (a,s)) - +unST (ST a) = a 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) +runST :: (__forall s . ST s a) -> a +runST m = fst (unST m alpha) where - theWorld :: RealWorld - theWorld = error "primRunST: entered the RealWorld" + alpha = error "runST: entered the RealWorld" -unST (ST a) = a +fixST :: (a -> ST s a) -> ST s a +fixST m = ST (\ s -> + let + (r,s) = unST (m r) s + in + (r,s)) instance Functor (ST s) where fmap f x = x >>= (return . f) @@ -1817,32 +1800,69 @@ instance Monad (ST s) where return x = ST (\s -> (x,s)) m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' }) +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) + +------------------------------------------------------------------------------ +-- IO ------------------------------------------------------------------------ +------------------------------------------------------------------------------ + +newtype IO a = IO (RealWorld -> (a,RealWorld)) +unIO (IO a) = a + +stToIO :: ST RealWorld a -> IO a +stToIO (ST fn) = IO fn + +ioToST :: IO a -> ST RealWorld a +ioToST (IO fn) = ST fn + +unsafePerformIO :: IO a -> a +unsafePerformIO m = fst (unIO m theWorld) + where + theWorld :: RealWorld + theWorld = error "unsafePerformIO: entered the RealWorld" + +instance Functor IO where + fmap f x = x >>= (return . f) + +instance Monad IO where + m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' }) + return x = IO (\s -> (x,s)) + m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (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 = unsafePerformIO (newIORef Nothing) -- used when Hugs invokes top level function -primRunIO :: IO () -> () -primRunIO m - = protect 5 (fst (unST m realWorld)) +hugsprimRunIO_toplevel :: IO a -> () +hugsprimRunIO_toplevel m + = protect 5 (fst (unIO 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 = 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 - = 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)) + (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld)) unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO = unsafeInterleaveST - +unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s)) ------------------------------------------------------------------------------ -- Word, Addr, StablePtr, Prim*Array ----------------------------------------- @@ -1889,16 +1909,24 @@ freeStablePtr = primFreeStablePtr 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 -newRef :: a -> ST s (Ref s a) -newRef = primNewRef -readRef :: Ref s a -> ST s a -readRef = primReadRef -writeRef :: Ref s a -> a -> ST s () -writeRef = primWriteRef +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 + +newtype IORef a = IORef (STRef RealWorld a) +newIORef :: a -> IO (IORef a) +newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref)) +readIORef :: IORef a -> IO a +readIORef (IORef ref) = stToIO (primReadRef ref) +writeIORef :: IORef a -> a -> IO () +writeIORef (IORef ref) a = stToIO (primWriteRef ref a) ------------------------------------------------------------------------------ @@ -1915,7 +1943,7 @@ putMVar = primPutMVar takeMVar :: MVar a -> IO a takeMVar m - = ST (\world -> primTakeMVar m cont world) + = IO (\world -> primTakeMVar m cont world) where -- cont :: a -> RealWorld -> (a,RealWorld) -- where 'a' is as in the top-level signature @@ -1974,17 +2002,19 @@ instance Ord ThreadId where forkIO :: IO a -> IO ThreadId -- Simple version; doesn't catch exceptions in computation -- forkIO computation --- = primForkIO (primRunST computation) +-- = primForkIO (unsafePerformIO computation) forkIO computation = primForkIO ( primCatch - (unST computation realWorld `primSeq` ()) + (unIO computation realWorld `primSeq` ()) (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ()) ) where realWorld = error "primForkIO: entered the RealWorld" +trace_quiet s x + = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x -- showFloat ------------------------------------------------------------------