[project @ 2000-03-02 10:10:33 by sewardj]

Changes needed to support foreign export (dynamic) in combined mode.

diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index da604fc..d0e753c 100644 (file)
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: interface.c,v $
- * $Revision: 1.32 $
- * $Date: 2000/02/24 12:34:18 $
+ * $Revision: 1.33 $
+ * $Date: 2000/03/02 10:10:33 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -2519,6 +2519,9 @@ Type type; {
       Sym(prog_argv)                 \
       Sym(prog_argc)                 \
       Sym(resetNonBlockingFd)        \
+      Sym(getStablePtr)              \
+      Sym(stable_ptr_table)          \
+      Sym(createAdjThunk)            \
                                      \
       /* needed by libHS_cbits */    \
       SymX(malloc)                   \

diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 9fcb210..09d1a03 100644 (file)
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -1560,6 +1560,11 @@ hugsprimPmFail       :: a
 hugsprimPmFail        = error "Pattern Match Failure"
 
 -- used in desugaring Foreign functions
+-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
+-- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
+-- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
+-- contains a version used in combined mode.  That version takes care of
+-- switching between the GHC and Hugs IO representations, which are different.
 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
 hugsprimMkIO = ST
 

diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 932f553..167fece 100644 (file)
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.h,v $
- * $Revision: 1.29 $
- * $Date: 2000/02/25 10:53:54 $
+ * $Revision: 1.30 $
+ * $Date: 2000/03/02 10:10:33 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -547,7 +547,7 @@ extern void* lookupOExtraTabName ( char* sym );
 
 #define isPrelude(m) (m==modulePrelude)
 
-#define N_PRELUDE_SCRIPTS (combined ? 30 : 1)
+#define N_PRELUDE_SCRIPTS (combined ? 32 : 1)
 
 /* --------------------------------------------------------------------------
  * Type constructor names:

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index ead65fc..d22ebd1 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.24 $
- * $Date: 1999/12/10 15:59:56 $
+ * $Revision: 1.25 $
+ * $Date: 2000/03/02 10:10:33 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -899,17 +899,15 @@ Void implementForeignImport ( Name n )
        descriptor->arg_tys++;
        descriptor->num_args--;
     }
-
-    
 }
 
 
 /* Generate code:
  *
- * \ fun s0 ->
+ * \ fun ->
      let e1 = A# "...."
          e3 = C# 'c' -- (ccall), or 's' (stdcall)
-     in  primMkAdjThunk fun e1 e3 s0
+     in  primMkAdjThunk fun e1 e3
 
    we require, and check that,
      fun :: prim_arg* -> IO prim_result
@@ -942,7 +940,7 @@ Void implementForeignExport ( Name n )
         assert(length(resultTys) == 1);
         resultTys = hd(resultTys);
     } else {
-        ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
+        ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
         ERRTEXT " \"" ETHEN ERRTYPE(t);
         ERRTEXT "\""
         EEND;        
@@ -966,7 +964,6 @@ Void implementForeignExport ( Name n )
     else
        internal ( "implementForeignExport: unknown calling convention");
 
-
     {
     List     tdList;
     Text     tdText;
@@ -979,7 +976,7 @@ Void implementForeignExport ( Name n )
        tdList = cons(foreignOutboundTy(resultTys),tdList);
 
     tdText = findText(charListToString ( tdList ));
-    args   = makeArgs(2);
+    args   = makeArgs(1);
     e1     = mkStgVar(
                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
                 NIL
@@ -998,7 +995,7 @@ Void implementForeignExport ( Name n )
                    tripleton(e1,e2,e3),
                    mkStgApp(
                       nameCreateAdjThunk,
-                      cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
+                      cons(hd(args),cons(e2,cons(e3,NIL)))
                    )
                 )
              );

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 9fcb210..09d1a03 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -1560,6 +1560,11 @@ hugsprimPmFail       :: a
 hugsprimPmFail        = error "Pattern Match Failure"
 
 -- used in desugaring Foreign functions
+-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
+-- bit of code of type   RealWorld -> (a,RealWorld)   into a proper IO value.
+-- What follows is the version for standalone mode.  ghc/lib/std/PrelHugs.lhs
+-- contains a version used in combined mode.  That version takes care of
+-- switching between the GHC and Hugs IO representations, which are different.
 hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
 hugsprimMkIO = ST
 

diff --git a/ghc/lib/std/PrelHugs.lhs b/ghc/lib/std/PrelHugs.lhs
index 6138c53..805f7b7 100644 (file)
--- a/ghc/lib/std/PrelHugs.lhs
+++ b/ghc/lib/std/PrelHugs.lhs
@@ -38,9 +38,11 @@ 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 
@@ -73,10 +75,42 @@ connectWorlds hrealworld
 
 
 
+-- 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)

diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 17eb97a..66d3758 100644 (file)
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.11 1999/11/08 15:30:37 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.12 2000/03/02 10:10:34 sewardj Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -386,7 +386,7 @@ int ccall ( CFunDescriptor*  d,
    for a given function by name.  Useful but a hack.  Sigh.
  */
 extern void* getHugs_AsmObject_for ( char* s );
-
+extern int /*Bool*/ combined;
 
 /* ----------------------------------------------------------------*
  * The implementation for x86_ccall and x86_stdcall.
@@ -464,12 +464,16 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
       }
       argp++;
    }
-
-   node = rts_apply ( 
-             asmClosureOfObject(getHugs_AsmObject_for("primRunST")), 
-             node );
-
-   sstat = rts_eval ( node, &nodeOut );
+fprintf(stderr,"before rts_evalIO\n");
+   if (combined) {
+      sstat = rts_evalIO ( node, &nodeOut );
+   } else {
+      node = rts_apply ( 
+                asmClosureOfObject(getHugs_AsmObject_for("primRunST")), 
+                node );
+      sstat = rts_eval ( node, &nodeOut );
+   }
+fprintf(stderr, "after rts_evalIO\n");
    if (sstat != Success)
       barf ("unpackArgsAndCallHaskell_x86_nocallconv: eval failed");
 
@@ -519,10 +523,10 @@ unpackArgsAndCallHaskell_x86_nocallconv_INTISH (
       StgStablePtr stableptr, char* tydesc, char* args
    )
 {
-   HaskellObj nodeOut
-      = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
-           stableptr, tydesc, args 
-        );
+   HaskellObj nodeOut;
+   nodeOut = unpackArgsAndCallHaskell_x86_nocallconv_wrk ( 
+                stableptr, tydesc, args 
+             );
    /* A complete hack.  We know that all these returns will be
       put into %eax (and %edx, if it is a 64-bit return), and
       the adjustor thunk will then itself return to the original