%
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -fcompiling-prelude #-}
module PrelHugs (
hugsprimPmInt,
import Prelude(fromIntegral)
import IO(putStr,hFlush,stdout,stderr)
import PrelException(catch,catchException)
-import PrelIOBase(IO,unsafePerformIO)
+import PrelIOBase(IO(..),unsafePerformIO)
import PrelShow(show,shows,showString,showChar,Show,ShowS)
import PrelRead(Read,ReadS,lex,reads)
import PrelFloat(Double)
import PrelReal(Fractional,fromRational,toRational)
-import PrelAddr(Addr)
+import PrelAddr(Addr(..),nullAddr)
+import PrelStable(StablePtr,makeStablePtr)
import PrelErr(error)
import PrelPack(unpackCString)
+import List(length)
-- Stuff needed by Hugs for desugaring. Do not mess with these!
-- They need to correspond exactly to versions written in
-- the Hugs standalone Prelude.
---hugs doesn't know about RealWorld and so throws this
---away if the original type signature is used
---hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+-- hugs doesn't know about RealWorld and so throws this
+-- away if the original type signature is used
+-- hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+--
+-- The first arg is an IO value created by Hugs, without the
+-- newtype ST wrapper. What we do here place a wrapper around
+-- it, so that it can be called from GHC-land, which uses a
+-- different IO representation.
+--
+-- This is all very delicate and relies crucially on the non-inlined
+-- connectWorlds fn to create an artificial dependency of the hugs_ioaction
+-- on the grealworld. That's needed to stop the simplifier floating
+-- the case outside of the \ grealworld.
hugsprimMkIO :: (rw -> (a,rw)) -> IO a
-hugsprimMkIO
- = error "hugsprimMkIO in combined mode: unimplemented"
+hugsprimMkIO hugs_ioaction
+ = IO ( \ grealworld -> case hugs_ioaction
+ (connectWorlds grealworld) of
+ (res, hrealworld') -> (# grealworld, res #)
+ )
+{-# NOINLINE connectWorlds #-}
+connectWorlds :: State# RealWorld -> a -- really, -> Hugs' RealWorld
+connectWorlds hrealworld
+ = error "connectWorlds: hugs entered the RealWorld"
+
+
+
+-- StgAddr createAdjThunk ( StgStablePtr stableptr,
+-- StgAddr typestr,
+-- StgChar callconv )
+
+foreign import "createAdjThunk" hugsCreateAdjThunk
+ :: StablePtr (a -> b) -> Addr{-mallocville String-} -> Char -> IO Addr
+foreign import "malloc" malloc
+ :: Int -> IO Addr
hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
hugsprimCreateAdjThunk fun typestr callconv
- = error "hugsprimCreateAdjThunk in combined mode: unimplemented"
+ = do sp <- makeStablePtr fun
+ p <- copy_String_to_cstring typestr -- is never freed
+ a <- hugsCreateAdjThunk sp p callconv
+ return a
+ where
+ copy_String_to_cstring :: String -> IO Addr
+ copy_String_to_cstring s
+ = malloc (1 + length s) >>= \ptr0 ->
+ let loop off [] = writeCharOffAddr ptr0 off (chr 0)
+ >> return ptr0
+ loop off (c:cs) = writeCharOffAddr ptr0 off c
+ >> loop (off+1) cs
+ in
+ if isNullAddr ptr0
+ then error "copy_String_to_cstring: malloc failed"
+ else loop 0 s
+
+ isNullAddr a = a == nullAddr
+
+ writeCharOffAddr :: Addr -> Int -> Char -> IO ()
+ writeCharOffAddr (A# buf#) (I# n#) (C# c#)
+ = IO ( \ s# ->
+ case (writeCharOffAddr# buf# n# c# s#) of
+ s2# -> (# s2#, () #) )
+
+
fromDouble :: Fractional a => Double -> a
fromDouble n = fromRational (toRational n)