-- module Ratio,
Ratio, Rational, (%), numerator, denominator, approxRational,
-- Non-standard exports
- IO(..), IOResult(..), Addr,
+ IO(..), IOResult(..), Addr, StablePtr,
+ makeStablePtr, freeStablePtr, deRefStablePtr,
Bool(False, True),
Maybe(Nothing, Just),
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),
isInfinite, isDenormalized, isIEEE, isNegativeZero),
Monad((>>=), (>>), return, fail),
Functor(fmap),
- mapM, mapM_, accumulate, sequence, (=<<),
+ mapM, mapM_, sequence, sequence_, (=<<),
maybe, either,
(&&), (||), not, otherwise,
subtract, even, odd, gcd, lcm, (^), (^^),
asTypeOf, error, undefined,
seq, ($!)
- ,primCompAux
+ , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar
+ , ThreadId, forkIO
+ ,trace
+
+ , STRef, newSTRef, readSTRef, writeSTRef
+ , IORef, newIORef, readIORef, writeIORef
+
+ -- This lot really shouldn't be exported, but are needed to
+ -- implement various libs.
+ ,hugsprimCompAux,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,
+ 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} ----------------------------------------
(/) :: 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 ------------------------------------------------------
p >> q = p >>= \ _ -> q
fail s = error s
-accumulate :: Monad m => [m a] -> m [a]
-accumulate [] = return []
-accumulate (c:cs) = do x <- c
- xs <- accumulate cs
- return (x:xs)
+sequence :: Monad m => [m a] -> m [a]
+sequence [] = return []
+sequence (c:cs) = do x <- c
+ xs <- sequence cs
+ return (x:xs)
-sequence :: Monad m => [m a] -> m ()
-sequence = foldr (>>) (return ())
+sequence_ :: Monad m => [m a] -> m ()
+sequence_ = foldr (>>) (return ())
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-mapM f = accumulate . map f
+mapM f = sequence . map f
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-mapM_ f = sequence . map f
+mapM_ f = sequence_ . map f
(=<<) :: Monad m => (a -> m b) -> m a -> m b
f =<< x = x >>= f
-- Evaluation and strictness ------------------------------------------------
seq :: a -> b -> b
-seq x y = --case primForce x of () -> y
- primSeq x y
+seq x y = primSeq x y
($!) :: (a -> b) -> a -> b
-f $! x = x `seq` f x
+f $! x = x `primSeq` f x
-- Trivial type -------------------------------------------------------------
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
-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
-- etc..
--- Functions ----------------------------------------------------------------
-
-instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
-
-instance Functor ((->) a) where
- fmap = (.)
-
-- Standard Integral types --------------------------------------------------
data Int -- builtin datatype of fixed size integers
instance Integral Integer where
quotRem = primQuotRemInteger
- divMod = primDivModInteger
+ --divMod = primDivModInteger
toInteger = id
toInt = primIntegerToInt
numericEnumFromThen n m = iterate ((m-n)+) n
numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
- where p | n' > n = (<= m)
+ where p | n' >= n = (<= m)
| otherwise = (>= m)
instance Read Int where
instance Show Integer where
showsPrec = showSigned showInt
+
-- Standard Floating types --------------------------------------------------
data Float -- builtin datatype of single precision floating point numbers
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
readsPrec p = readSigned readFloat
instance Show Float where
- showsPrec p = showFloat
- --error "should call showFloat"
+ showsPrec p = showSigned showFloat p
instance Read Double where
readsPrec p = readSigned readFloat
--- Note that showFloat in Numeric isn't used here
instance Show Double where
- showsPrec p = showFloat
- --error "should call showFloat"
+ showsPrec p = showSigned showFloat p
+
-- Some standard functions --------------------------------------------------
(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
(x:xs) ++ ys = x : (xs ++ ys)
map :: (a -> b) -> [a] -> [b]
-map f xs = [ f x | x <- xs ]
+--map f xs = [ f x | x <- xs ]
+map f [] = []
+map f (x:xs) = f x : map f xs
+
filter :: (a -> Bool) -> [a] -> [a]
-filter p xs = [ x | x <- xs, p x ]
+--filter p xs = [ x | x <- xs, p x ]
+filter p [] = []
+filter p (x:xs) = if p x then x : filter p xs else filter p xs
+
concat :: [[a]] -> [a]
-concat = foldr (++) []
+--concat = foldr (++) []
+concat [] = []
+concat (xs:xss) = xs ++ concat xss
length :: [a] -> Int
-length = foldl' (\n _ -> n + 1) 0
+--length = foldl' (\n _ -> n + 1) 0
+length [] = 0
+length (x:xs) = let n = length xs in primSeq n (1+n)
(!!) :: [b] -> Int -> b
(x:_) !! 0 = x
unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
reverse :: [a] -> [a]
-reverse = foldl (flip (:)) []
+--reverse = foldl (flip (:)) []
+reverse xs = ri [] xs
+ where ri acc [] = acc
+ ri acc (x:xs) = ri (x:acc) xs
and, or :: [Bool] -> Bool
-and = foldr (&&) True
-or = foldr (||) False
+--and = foldr (&&) True
+--or = foldr (||) False
+and [] = True
+and (x:xs) = if x then and xs else x
+or [] = False
+or (x:xs) = if x then x else or xs
any, all :: (a -> Bool) -> [a] -> Bool
-any p = or . map p
-all p = and . map p
+--any p = or . map p
+--all p = and . map p
+any p [] = False
+any p (x:xs) = if p x then True else any p xs
+all p [] = True
+all p (x:xs) = if p x then all p xs else False
elem, notElem :: Eq a => a -> [a] -> Bool
-elem = any . (==)
-notElem = all . (/=)
+--elem = any . (==)
+--notElem = all . (/=)
+elem x [] = False
+elem x (y:ys) = if x==y then True else elem x ys
+notElem x [] = True
+notElem x (y:ys) = if x==y then False else notElem x ys
lookup :: Eq a => a -> [(a,b)] -> Maybe b
lookup k [] = Nothing
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 "" = [("","")]
lexLitChar :: ReadS String
lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
where
- lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] -- "
lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
lexEsc s@(d:_) | isDigit d = lexDigits s
lexEsc s@(c:_) | isUpper c
-- showInt is used for positive numbers only
showInt :: Integral a => a -> ShowS
-showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
- | otherwise =
- let (n',d) = quotRem n 10
- r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
+showInt n r
+ | n < 0
+ = error "Numeric.showInt: can't show negative numbers"
+ | otherwise
+{-
+ = let (n',d) = quotRem n 10
+ r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+-}
+ = case quotRem n 10 of { (n',d) ->
+ let r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+ }
+
readSigned:: Real a => ReadS a -> ReadS a
readSigned readPos = readParen False read'
-- 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
-primPmInt :: Num a => Int -> a -> Bool
-primPmInt n x = fromInt n == x
+hugsprimEqChar :: Char -> Char -> Bool
+hugsprimEqChar c1 c2 = primEqChar c1 c2
-primPmInteger :: Num a => Integer -> a -> Bool
-primPmInteger n x = fromInteger n == x
+hugsprimPmInt :: Num a => Int -> a -> Bool
+hugsprimPmInt n x = fromInt n == x
-primPmFlt :: Fractional a => Double -> a -> Bool
-primPmFlt n x = fromDouble n == x
+hugsprimPmInteger :: Num a => Integer -> a -> Bool
+hugsprimPmInteger n x = fromInteger 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"
-primPmFailBUG :: a
-primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++
- "**Please** report to v-julsew@microsoft.com. Thx!\n")
+hugsprimPmFail :: a
+hugsprimPmFail = error "Pattern Match Failure"
-- used in desugaring Foreign functions
-primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-primMkIO = ST
+hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+hugsprimMkIO = ST
+
+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
userError s = primRaise (ErrorCall s)
catch :: IO a -> (IOError -> IO a) -> IO a
-catch x eh = primCatch x (eh.exception2ioerror)
- where
- exception2ioerror (IOExcept s) = IOError s
- exception2ioerror other = IOError (show other)
+catch m k
+ = ST (\s -> unST m s `primCatch` \ err -> unST (k (e2ioe err)) s)
+ where
+ e2ioe (IOExcept s) = IOError s
+ e2ioe other = IOError (show other)
putChar :: Char -> IO ()
-putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
+putChar c = nh_stdout >>= \h -> nh_write h c
putStr :: String -> IO ()
-putStr s = --mapM_ putChar s -- correct, but slow
- nh_stdout >>= \h ->
- let loop [] = return ()
- loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
+putStr s = nh_stdout >>= \h ->
+ let loop [] = nh_flush h
+ loop (c:cs) = nh_write h c >> loop cs
in loop s
putStrLn :: String -> IO ()
readFile :: FilePath -> IO String
readFile fname
- = fileopen_sendname fname >>= \ptr ->
+ = copy_String_to_cstring fname >>= \ptr ->
nh_open ptr 0 >>= \h ->
nh_free ptr >>
nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
+ if (isNullAddr h || errno /= 0)
then (ioError.IOError) ("readFile: can't open file " ++ fname)
else readfromhandle h
writeFile :: FilePath -> String -> IO ()
writeFile fname contents
- = fileopen_sendname fname >>= \ptr ->
+ = copy_String_to_cstring fname >>= \ptr ->
nh_open ptr 1 >>= \h ->
nh_free ptr >>
nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
+ if (isNullAddr h || errno /= 0)
then (ioError.IOError) ("writeFile: can't create file " ++ fname)
else writetohandle fname h contents
-
appendFile :: FilePath -> String -> IO ()
appendFile fname contents
- = fileopen_sendname fname >>= \ptr ->
+ = copy_String_to_cstring fname >>= \ptr ->
nh_open ptr 2 >>= \h ->
nh_free ptr >>
nh_errno >>= \errno ->
- if (h == 0 || errno /= 0)
+ if (isNullAddr h || errno /= 0)
then (ioError.IOError) ("appendFile: can't open file " ++ fname)
else writetohandle fname h contents
data IOResult = IOResult deriving (Show)
-type FILE_STAR = Int
-
-foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
-foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
-foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
-foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
-
-foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int
-foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO ()
-foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int
-
-fileopen_sendname :: String -> IO Int
-fileopen_sendname fname
- = nh_malloc (1 + length fname) >>= \ptr ->
- let loop i [] = nh_assign ptr i 0 >> return ptr
- loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs
+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_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_malloc (1 + length s) >>= \ptr0 ->
+ let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
+ loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
in
- loop 0 fname
+ if isNullAddr ptr0
+ then error "copy_String_to_cstring: malloc failed"
+ else loop ptr0 s
+
+copy_cstring_to_String :: Addr -> IO String
+copy_cstring_to_String ptr
+ = nh_load ptr >>= \ci ->
+ if ci == '\0'
+ then return []
+ else copy_cstring_to_String (incAddr ptr) >>= \cs ->
+ return (ci : cs)
readfromhandle :: FILE_STAR -> IO String
readfromhandle h
then return ()
else error ( "writeFile/appendFile: error closing file " ++ fname)
writetohandle fname h (c:cs)
- = nh_write h (primCharToInt c) >>
- writetohandle fname h cs
+ = nh_write h c >> writetohandle fname h cs
+
+primGetRawArgs :: IO [String]
+primGetRawArgs
+ = primGetArgc >>= \argc ->
+ sequence (map get_one_arg [0 .. argc-1])
+ where
+ get_one_arg :: Int -> IO String
+ get_one_arg argno
+ = primGetArgv argno >>= \a ->
+ copy_cstring_to_String a
+
+primGetEnv :: String -> IO String
+primGetEnv v
+ = copy_String_to_cstring v >>= \ptr ->
+ nh_getenv ptr >>= \ptr2 ->
+ nh_free ptr >>
+ if isNullAddr ptr2
+ then return []
+ else
+ copy_cstring_to_String ptr2 >>= \result ->
+ return result
+
------------------------------------------------------------------------------
-- ST, IO --------------------------------------------------------------------
data RealWorld
type IO a = ST RealWorld a
-
---runST :: (forall s. ST s a) -> a
-runST :: ST RealWorld a -> a
-runST m = fst (unST m theWorld)
+--primRunST :: (forall s. ST s a) -> a
+primRunST :: ST RealWorld a -> a
+primRunST m = fst (unST m theWorld)
where
theWorld :: RealWorld
- theWorld = error "runST: entered the RealWorld"
+ theWorld = error "primRunST: entered the RealWorld"
unST (ST a) = a
instance Functor (ST s) where
- fmap f x = x >>= (return . f)
+ fmap f x = x >>= (return . f)
instance Monad (ST s) where
- m >> k = m >>= \ _ -> k
- return x = ST $ \ s -> (x,s)
- m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
+ m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
+ return x = ST (\s -> (x,s))
+ 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 (fst (unST m realWorld))
+hugsprimRunIO_toplevel :: IO a -> ()
+hugsprimRunIO_toplevel m
+ = protect 5 (fst (unST composite_action realWorld))
where
- realWorld = error "panic: Hugs entered the real world"
- protect :: () -> ()
- protect comp
- = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld))
-
-trace :: String -> a -> a
+ 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
- = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` 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))
------------------------------------------------------------------------------
--- Addr, ForeignObj, Prim*Array ----------------------------------------------
+-- Word, Addr, StablePtr, Prim*Array -----------------------------------------
------------------------------------------------------------------------------
data Addr
-nullAddr = primIntToAddr 0
+nullAddr = primIntToAddr 0
+incAddr a = primIntToAddr (1 + primAddrToInt a)
+isNullAddr a = 0 == primAddrToInt a
instance Eq Addr where
(==) = primEqAddr
(>=) = primGeAddr
(>) = primGtAddr
+data Word
-data ForeignObj
-makeForeignObj :: Addr -> IO ForeignObj
-makeForeignObj = primMakeForeignObj
+instance Eq Word where
+ (==) = primEqWord
+ (/=) = primNeWord
+
+instance Ord Word where
+ (<) = primLtWord
+ (<=) = primLeWord
+ (>=) = primGeWord
+ (>) = primGtWord
+
+data StablePtr a
+
+makeStablePtr :: a -> IO (StablePtr a)
+makeStablePtr = primMakeStablePtr
+deRefStablePtr :: StablePtr a -> IO a
+deRefStablePtr = primDeRefStablePtr
+freeStablePtr :: StablePtr a -> IO ()
+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
+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
-------------------------------------------------------------------------------
--- hooks to call libHS_cbits -------------------------------------------------
-------------------------------------------------------------------------------
-{-
-type FILE_OBJ = ForeignObj -- as passed into functions
-type CString = PrimByteArray
-type How = Int
-type Binary = Int
-type OpenFlags = Int
-type IOFileAddr = Addr -- as returned from functions
-type FD = Int
-type OpenStdFlags = Int
-type Readable = Int -- really Bool
-type Exclusive = Int -- really Bool
-type RC = Int -- standard return code
-type Bytes = PrimMutableByteArray RealWorld
-type Flush = Int -- really Bool
-
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
- freeStdFileObject :: ForeignObj -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "freeFileObject"
- freeFileObject :: ForeignObj -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "setBuf"
- prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "getBufSize"
- prim_getBufSize :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "inputReady"
- prim_inputReady :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "fileGetc"
- prim_fileGetc :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "fileLookAhead"
- prim_fileLookAhead :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readBlock"
- prim_readBlock :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readLine"
- prim_readLine :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "readChar"
- prim_readChar :: FILE_OBJ -> IO Int
+type IORef a = STRef RealWorld a
+newIORef :: a -> IO (IORef a)
+newIORef = primNewRef
+readIORef :: IORef a -> IO a
+readIORef = primReadRef
+writeIORef :: IORef a -> a -> IO ()
+writeIORef = primWriteRef
-foreign import stdcall "libHS_cbits.so" "writeFileObject"
- prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "filePutc"
- prim_filePutc :: FILE_OBJ -> Char -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getBufStart"
- prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
- prim_getWriteableBuf :: FILE_OBJ -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getBufWPtr"
- prim_getBufWPtr :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "setBufWPtr"
- prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "closeFile"
- prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "fileEOF"
- prim_fileEOF :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setBuffering"
- prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "flushFile"
- prim_flushFile :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getBufferMode"
- prim_getBufferMode :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "seekFileP"
- prim_seekFileP :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
- prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
- prim_getTerminalEcho :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
- prim_isTerminalDevice :: FILE_OBJ -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "setConnectedTo"
- prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "ungetChar"
- prim_ungetChar :: FILE_OBJ -> Char -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "readChunk"
- prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "writeBuf"
- prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getFileFd"
- prim_getFileFd :: FILE_OBJ -> IO FD
-
-foreign import stdcall "libHS_cbits.so" "fileSize_int64"
- prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "getFilePosn"
- prim_getFilePosn :: FILE_OBJ -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "setFilePosn"
- prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
-
-foreign import stdcall "libHS_cbits.so" "getConnFileFd"
- prim_getConnFileFd :: FILE_OBJ -> IO FD
-
-foreign import stdcall "libHS_cbits.so" "allocMemory__"
- prim_allocMemory__ :: Int -> IO Addr
-
-foreign import stdcall "libHS_cbits.so" "getLock"
- prim_getLock :: FD -> Exclusive -> IO RC
-
-foreign import stdcall "libHS_cbits.so" "openStdFile"
- prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
-
-foreign import stdcall "libHS_cbits.so" "openFile"
- prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
-
-foreign import stdcall "libHS_cbits.so" "freeFileObject"
- prim_freeFileObject :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
- prim_freeStdFileObject :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
- const_BUFSIZ :: Int
-
-foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
- prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
- prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
- prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+------------------------------------------------------------------------------
+-- ThreadId, MVar, concurrency stuff -----------------------------------------
+------------------------------------------------------------------------------
-foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
- prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+data MVar a
-foreign import stdcall "libHS_cbits.so" "getErrStr__"
- prim_getErrStr__ :: IO Addr
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = primNewEmptyMVar
-foreign import stdcall "libHS_cbits.so" "getErrNo__"
- prim_getErrNo__ :: IO Int
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
-foreign import stdcall "libHS_cbits.so" "getErrType__"
- prim_getErrType__ :: IO Int
+takeMVar :: MVar a -> IO a
+takeMVar m
+ = ST (\world -> primTakeMVar m cont world)
+ where
+ -- cont :: a -> RealWorld -> (a,RealWorld)
+ -- where 'a' is as in the top-level signature
+ cont x world = (x,world)
+
+ -- the type of the handwritten BCO (threesome) primTakeMVar is
+ -- primTakeMVar :: MVar a
+ -- -> (a -> RealWorld -> (a,RealWorld))
+ -- -> RealWorld
+ -- -> (a,RealWorld)
+ --
+ -- primTakeMVar behaves like this:
+ --
+ -- primTakeMVar (MVar# m#) cont world
+ -- = primTakeMVar_wrk m# cont world
+ --
+ -- primTakeMVar_wrk m# cont world
+ -- = cont (takeMVar# m#) world
+ --
+ -- 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 (primRunST computation)
+
+forkIO computation
+ = primForkIO (
+ primCatch
+ (unST computation realWorld `primSeq` ())
+ (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
+ )
+ where
+ realWorld = error "primForkIO: entered the RealWorld"
---foreign import stdcall "libHS_cbits.so" "seekFile_int64"
--- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
--}
-- showFloat ------------------------------------------------------------------
doFmt fmt (is, e) =
let ds = map intToDigit is
in case fmt of
- FFGeneric ->
+ FFGeneric ->
doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
(is, e)
FFExponent ->
(f*2, b^(-e)*2, 1, 1)
k =
let k0 =
-
- 0
-
+ if b == 2 && base == 10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ log (fromInteger base))
fixup n =
if n >= 0 then
if r + mUp <= expt base n * s then n else fixup (n+1)
in gen [] (r * bk) s (mUp * bk) (mDn * bk)
in (map toInt (reverse rds), k)
--- Exponentiation with(out) a cache for the most common numbers.
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
expt :: Integer -> Int -> Integer
-expt base n = base^n
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts !! (n-minExpt)
+ else
+ base^n
+
+expts :: [Integer]
+expts = [2^n | n <- [minExpt .. maxExpt]]
+
projects / ghc-hetmet.git / blobdiff