||___|| ||__|| ||__|| __|| 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.
-- module Ratio,
Ratio, Rational, (%), numerator, denominator, approxRational,
-- Non-standard exports
- IO(..), IOResult(..), Addr, StablePtr,
+ IO, IOResult(..), Addr, StablePtr,
makeStablePtr, freeStablePtr, deRefStablePtr,
Bool(False, True),
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),
asTypeOf, error, undefined,
seq, ($!)
- , MVar, newMVar, putMVar, takeMVar
-
- ,trace
- -- 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} ----------------------------------------
(/) :: 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
-- 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 ------------------------------------------------------
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
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
(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
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
(")",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 "" = [("","")]
-- 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
-primPmSub :: Integral a => Int -> a -> a
-primPmSub n x = x - fromInt n
+hugsprimPmSubtract :: Integral a => a -> a -> a
+hugsprimPmSubtract x y = x - y
+
+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
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)
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
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
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 ------------------------------------------------------------------------
------------------------------------------------------------------------------
--- Do not change this newtype to a data, or MVars will stop
--- working. In general the MVar stuff is pretty fragile: do
--- not mess with it.
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)
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 (fst (unST m realWorld))
+hugsprimRunIO_toplevel :: IO a -> ()
+hugsprimRunIO_toplevel m
+ = protect 5 (fst (unIO composite_action realWorld))
where
- realWorld = error "primRunIO: entered the RealWorld"
- protect :: () -> ()
- protect comp
- = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
+ composite_action
+ = do writeIORef prelCleanupAfterRunAction Nothing
+ m
+ cleanup_handles <- readIORef prelCleanupAfterRunAction
+ case cleanup_handles of
+ Nothing -> return ()
+ Just xx -> xx
-trace :: String -> a -> a
-trace s x
- = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+ realWorld = error "primRunIO: entered the RealWorld"
+ protect :: Int -> () -> ()
+ protect 0 comp
+ = comp
+ protect n comp
+ = primCatch (protect (n-1) comp)
+ (\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, ThreadId, MVar -------------------------
+-- Word, Addr, StablePtr, Prim*Array -----------------------------------------
------------------------------------------------------------------------------
data Addr
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
-data ThreadId
+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
-data MVar a
+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)
-newMVar :: IO (MVar a)
-newMVar = primNewMVar
+------------------------------------------------------------------------------
+-- ThreadId, MVar, concurrency stuff -----------------------------------------
+------------------------------------------------------------------------------
+
+data MVar a
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = primNewEmptyMVar
putMVar :: MVar a -> a -> IO ()
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
-- primTakeMVar_wrk has the special property that it is
-- restartable by the scheduler, should the MVar be empty.
+newMVar :: a -> IO (MVar a)
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+readMVar :: MVar a -> IO a
+readMVar mvar =
+ takeMVar mvar >>= \ value ->
+ putMVar mvar value >>
+ return value
+
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new =
+ takeMVar mvar >>= \ old ->
+ putMVar mvar new >>
+ return old
+
+instance Eq (MVar a) where
+ m1 == m2 = primSameMVar m1 m2
+
+
+data ThreadId
+
+instance Eq ThreadId where
+ tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
+
+instance Ord ThreadId where
+ compare tid1 tid2
+ = let r = primCmpThreadIds tid1 tid2
+ in if r < 0 then LT else if r > 0 then GT else EQ
+
+
+forkIO :: IO a -> IO ThreadId
+-- Simple version; doesn't catch exceptions in computation
+-- forkIO computation
+-- = primForkIO (unsafePerformIO computation)
+
+forkIO computation
+ = primForkIO (
+ primCatch
+ (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 ------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff