From 8b64c2c50efae45b6073f44fc54227889a0275dc Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Tue, 29 Feb 2000 12:54:52 +0000
Subject: [PATCH] [project @ 2000-02-29 12:54:51 by sewardj] Make foreign
 import work in combined mode: -- Allow interpreter to do
 ccall primops even in combined mode -- Implement
 hugsprimMkIO in combined mode, so as to wrap up a    an IO
 value created by Hugs in a form compatible with GHC's IO   
 representation.

---
 ghc/lib/std/PrelHugs.lhs |   33 +++++++++++++++++++++++++++------
 ghc/rts/Evaluator.c      |   14 ++++++++++----
 2 files changed, 37 insertions(+), 10 deletions(-)

diff --git a/ghc/lib/std/PrelHugs.lhs b/ghc/lib/std/PrelHugs.lhs
index 6df8cc6..6138c53 100644
--- a/ghc/lib/std/PrelHugs.lhs
+++ b/ghc/lib/std/PrelHugs.lhs
@@ -33,7 +33,7 @@ import PrelReal(Integral)
 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)
@@ -46,12 +46,33 @@ import PrelPack(unpackCString)
 -- 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"
+
+
+
 
 hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
 hugsprimCreateAdjThunk fun typestr callconv
diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c
index 7522bed..c67ff2c 100644
--- a/ghc/rts/Evaluator.c
+++ b/ghc/rts/Evaluator.c
@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.35 $
- * $Date: 2000/02/24 17:26:12 $
+ * $Revision: 1.36 $
+ * $Date: 2000/02/29 12:54:51 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -2665,8 +2665,14 @@ static void* enterBCO_primop2 ( int primop2code,
                                 StgBCO** bco,
                                 Capability* cap )
 {
-        if (combined)
-           barf("enterBCO_primop1 in combined mode");
+        if (combined) {
+	   /* A small concession: we need to allow ccalls, 
+              even in combined mode.
+           */
+           if (primop2code != i_ccall_ccall_IO &&
+               primop2code != i_ccall_stdcall_IO)
+              barf("enterBCO_primop2 in combined mode");
+        }
 
         switch (primop2code) {
         case i_raise:  /* raise#{err} */
-- 
1.7.10.4