[project @ 2000-04-12 11:49:50 by sewardj]

[ghc-hetmet.git] / ghc / lib / std / PrelHugs.lhs

diff --git a/ghc/lib/std/PrelHugs.lhs b/ghc/lib/std/PrelHugs.lhs
index 23a106f..897b6ea 100644 (file)
--- a/ghc/lib/std/PrelHugs.lhs
+++ b/ghc/lib/std/PrelHugs.lhs
@@ -3,7 +3,7 @@
 %
 
 \begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -fcompiling-prelude #-}
 
 module PrelHugs (
    hugsprimPmInt,
@@ -32,30 +32,85 @@ import PrelNum
 import PrelReal(Integral)
 import Prelude(fromIntegral)
 import IO(putStr,hFlush,stdout,stderr)
-import PrelException(catch)
-import PrelIOBase(IO,unsafePerformIO)
+import PrelException(catch,catchException)
+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)
@@ -129,12 +184,11 @@ hugsprimRunIO_toplevel m
            = primCatch (protect (n-1) comp)
                        (\e -> fst (unST (putStr (show e ++ "\n")) realWorld))
 -}
+
 hugsprimRunIO_toplevel :: IO a -> ()
 hugsprimRunIO_toplevel m
-   = unsafePerformIO (
-        catch (m >> hFlush stderr >> hFlush stdout)
-              (\e -> putStr (show e ++ "\n"))
-     )
-
-
+    = unsafePerformIO (
+         catchException (m >> hFlush stderr >> hFlush stdout)
+                        (\e -> putStr ("error: " ++ show e ++ "\n"))
+      )
 \end{code}
\ No newline at end of file