,trace
, STRef, newSTRef, readSTRef, writeSTRef
+ , IORef, newIORef, readIORef, writeIORef
- -- Arrrggghhh!!! Help! Help! Help!
- -- What?! Prelude.hs doesn't even _define_ most of these things!
+ -- This lot really shouldn't be exported, but are needed to
+ -- implement various libs.
,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,
+ nullAddr, incAddr, isNullAddr,
+ nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
+ nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
Word,
primGtWord, primGeWord, primEqWord, primNeWord,
primAddrToInt, primIntToAddr,
primDoubleToFloat, primFloatToDouble,
- -- debugging hacks
- --,ST(..)
- --,primIntToAddr
- --,primGetArgc
- --,primGetArgv
+
) where
-- Standard value bindings {Prelude} ----------------------------------------
-- 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 ------------------------------------------------------
primCompAux :: Ord a => a -> a -> Ordering -> Ordering
primCompAux 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
+
+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"
-- used in desugaring Foreign functions
-primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-primMkIO = ST
+hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+hugsprimMkIO = ST
-primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
-primCreateAdjThunk fun typestr callconv
+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
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
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)
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))
+hugsprimRunIO_toplevel :: IO a -> ()
+hugsprimRunIO_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
writeSTRef = primWriteRef
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
------------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff