[project @ 2000-05-12 11:59:38 by sewardj]

First try at support for DietHEP.  Has some unfindable bug which causes
it to fail when hugs.c is compiled -O; works fine without -O.

5 files changed, 188 insertions, 76 deletions

diff --git a/ghc/includes/DietHEP.h b/ghc/includes/DietHEP.h
new file mode 100644
index 0000000000..461164e0ad
--- /dev/null
+++ b/ghc/includes/DietHEP.h
@@ -0,0 +1,11 @@
+
+typedef enum { dh_stdcall, dh_ccall } DHCALLCONV;
+typedef int                           HMODULE;
+typedef char*                         LPCSTR;
+
+extern HMODULE LoadLibrary ( LPCSTR modname );
+extern void*   GetProcAddr ( DHCALLCONV cconv, 
+                             HMODULE    hModule, 
+                             LPCSTR     lpProcName );
+
+
diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h
index 430e130b29..52d894aed2 100644
--- a/ghc/interpreter/connect.h
+++ b/ghc/interpreter/connect.h
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: connect.h,v $
- * $Revision: 1.41 $
- * $Date: 2000/05/10 09:00:20 $
+ * $Revision: 1.42 $
+ * $Date: 2000/05/12 11:59:38 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -451,6 +451,7 @@ extern  Void  foreignImport     ( Cell,Text,Pair,Cell,Cell );
 extern  Void  foreignExport     ( Cell,Text,Cell,Cell,Cell );
 
 extern  Void  implementForeignImport ( Name );
+extern  Text  makeTypeDescrText      ( Type );
 extern  Void  implementForeignExport ( Name );
 
 extern  List  foreignExports;            /* foreign export declarations     */
diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 79a335c780..2e0b208451 100644
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.70 $
- * $Date: 2000/05/10 09:00:20 $
+ * $Revision: 1.71 $
+ * $Date: 2000/05/12 11:59:39 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -27,6 +27,8 @@
 #include "RtsAPI.h"
 #include "Schedule.h"
 #include "Assembler.h"                                /* DEBUG_LoadSymbols */
+#include "ForeignCall.h"                                 /* createAdjThunk */
+
 
 Bool haskell98 = TRUE;                  /* TRUE => Haskell 98 compatibility*/
 Bool initDone = FALSE;
@@ -82,6 +84,10 @@ static Void   local browseit	      ( Module,String,Bool );
 static Void   local browse	      ( Void );
 static void   local clearCurrentFile  ( void );
 
+static void loadActions ( List loadModules /* :: [CONID] */ );
+static void addActions ( List extraModules /* :: [CONID] */ );
+static Bool loadThePrelude ( void );
+
 
 /* --------------------------------------------------------------------------
  * Machine dependent code for Hugs interpreter:
@@ -130,37 +136,144 @@ static ConId currentModule_failed = NIL; /* Remember failed module from :r */
  * Hugs entry point:
  * ------------------------------------------------------------------------*/
 
-#ifndef NO_MAIN /* we omit main when building the "Hugs server" */
- 
-Main main ( Int, String [] );       /* now every func has a prototype  */
+#ifdef DIET_HEP
 
-Main main(argc,argv)
-int  argc;
-char *argv[]; {
-#ifdef HAVE_CONSOLE_H /* Macintosh port */
-    _ftype = 'TEXT';
-    _fcreator = 'R*ch';       /*  // 'KAHL';      //'*TEX';       //'ttxt'; */
+#include "diet_hep.h"
 
-    console_options.top = 50;
-    console_options.left = 20;
+static int diet_hep_initialised = 0;
 
-    console_options.nrows = 32;
-    console_options.ncols = 80;
+static
+void diet_hep_initialise ( void* cstackbase )
+{
+    List   modConIds; /* :: [CONID] */
+    Bool   prelOK;
+    String s;
+    String fakeargv[1] = { "diet_hep" };
 
-    console_options.pause_atexit = 1;
-    console_options.title = "\pHugs";
+    if (diet_hep_initialised) return;
+    diet_hep_initialised = 1;
 
-    console_options.procID = 5;
-    argc = ccommand(&argv);
-#endif
+    CStackBase = cstackbase;
+    EnableOutput(1);
+    setInstallDir ( "diet_hep" );
+
+    /* The following copied from interpreter() */
+    setBreakAction ( HugsIgnoreBreak );
+    modConIds = initialize(1,fakeargv);
+    assert(isNull(modConIds));
+    setBreakAction ( HugsIgnoreBreak );
+    prelOK    = loadThePrelude();
+
+    if (!prelOK) {
+       fprintf(stderr, "diet_hep_initialise: fatal error: "
+                       "can't load the Prelude.\n" );
+       exit(1);
+    }    
+
+    loadActions(NIL);
+
+    if (combined) everybody(POSTPREL);
+    /* we now leave, and wait for requests */
+}
+
+
+static
+HMODULE LoadLibrary_wrk ( LPCSTR modname )
+{
+   Text   t;
+   Module m;
+   t = findText(modname);
+   addActions ( singleton(mkCon(t)) );
+   m = findModule(t);
+   if (isModule(m)) return m; else return 0;
+}
 
+HMODULE LoadLibrary ( LPCSTR modname )
+{
+   int xxx;
+   HMODULE hdl;
+   diet_hep_initialise ( &xxx );
+   hdl = LoadLibrary_wrk ( modname );
+   printf ( "hdl = %d\n", hdl );
+   return hdl;
+}
+
+
+static
+void* GetProcAddr_wrk ( DHCALLCONV cconv,
+                        HMODULE    hModule,
+                        LPCSTR     lpProcName )
+{
+   Name  n;
+   Text  typedescr;
+   void* adj_thunk;
+   StgStablePtr stableptr;
+
+   if (!isModule(hModule)) return NULL;
+   setCurrModule(hModule);
+   n = findName ( findText(lpProcName) );
+   if (!isName(n)) return NULL;
+   assert(isCPtr(name(n).closure));
+
+   /* n is the function which we want to f-x-d,
+      n :: prim_arg* -> IO prim_result.
+      Assume that name(n).closure is a cptr which points to n's BCO.
+
+      Make ns a stable pointer to n.
+      Manufacture a type descriptor string for n's type.
+      use createAdjThunk to build the adj thunk.
+   */
+   typedescr = makeTypeDescrText ( name(n).type );
+   if (!isText(typedescr)) return NULL;
+   if (cconv != dh_stdcall && cconv != dh_ccall) return NULL;
+
+   stableptr = getStablePtr( cptrOf(name(n).closure) );
+   adj_thunk = createAdjThunk ( stableptr,
+                                textToStr(typedescr), 
+                                cconv==dh_stdcall ? 's' : 'c' );
+   return adj_thunk;
+}
+
+void* GetProcAddr ( DHCALLCONV cconv,
+                    HMODULE    hModule,
+                    LPCSTR     lpProcName )
+{
+   int xxx;
+   diet_hep_initialise ( &xxx );
+   return GetProcAddr_wrk ( cconv, hModule, lpProcName );
+}
+
+//---------------------------------
+//--- testing it ...
+int main ( int argc, char** argv )
+{
+   void*   proc;
+   HMODULE hdl;
+   hdl = LoadLibrary("FooBar");
+   assert(isModule(hdl));
+   proc = GetProcAddr ( dh_ccall, hdl, "wurble" );
+fprintf ( stderr, "just before calling it\n");
+   ((void(*)(int)) proc)  (33);
+   ((void(*)(int)) proc)  (34);
+   ((void(*)(int)) proc)  (35);
+   fprintf ( stderr, "exiting safely\n");
+   return 0;
+}
+
+#else
+
+Main main ( Int, String [] );       /* now every func has a prototype  */
+
+Main main(argc,argv)
+int  argc;
+char *argv[]; {
     CStackBase = &argc;                 /* Save stack base for use in gc   */
 
-#ifdef DEBUG
-#if 0
+#   ifdef DEBUG
+#   if 0
     checkBytecodeCount();		/* check for too many bytecodes    */
-#endif
-#endif
+#   endif
+#   endif
 
     /* If first arg is +Q or -Q, be entirely silent, and automatically run
        main after loading scripts.  Useful for running the nofib suite.    */
@@ -185,9 +298,6 @@ char *argv[]; {
     */
     setInstallDir ( argv[0] );
 
-#if SYMANTEC_C
-    Printf("   Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
-#endif
     FlushStdout();
     interpreter(argc,argv);
     Printf("[Leaving Hugs]\n");
@@ -199,7 +309,7 @@ char *argv[]; {
     MainDone();
 }
 
-#endif
+#endif /* DIET_HEP */
 
 /* --------------------------------------------------------------------------
  * Initialization, interpret command line args and read prelude:
diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 0ccd6eb1fb..a4e3b9d1ef 100644
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.34 $
- * $Date: 2000/04/27 16:35:29 $
+ * $Revision: 1.35 $
+ * $Date: 2000/05/12 11:59:39 $
  * ------------------------------------------------------------------------*/
 
 #include "hugsbasictypes.h"
@@ -33,22 +33,6 @@ static StgExpr    local stgExpr      ( Cell,Int,List,StgExpr );
 
 /* ---------------------------------------------------------------- */
 
-#if 0
-static StgVar local getSTGTupleVar ( Cell d )
-{
-    Pair p = cellAssoc(d,stgGlobals);
-    /* Yoiks - only the Prelude sees Tuple decls! */
-    if (isNull(p)) {
-        implementTuple(tupleOf(d));
-        p = cellAssoc(d,stgGlobals);
-    }
-    assert(nonNull(p));
-    return snd(p);
-}
-#endif
-
-/* ---------------------------------------------------------------- */
-
 static Cell local stgOffset(Offset o, List sc)
 {
     Cell r = cellAssoc(o,sc);
@@ -85,7 +69,6 @@ StgExpr failExpr; {
     case VAROPCELL:
             return stgText(textOf(e),sc);
     case TUPLE: 
-      /* return getSTGTupleVar(e); */
          return e;
     case NAME:
             return e;
@@ -886,6 +869,7 @@ Void implementForeignImport ( Name n )
 }
 
 
+
 /* Generate code:
  *
  * \ fun ->
@@ -896,22 +880,20 @@ Void implementForeignImport ( Name n )
    we require, and check that,
      fun :: prim_arg* -> IO prim_result
  */
-Void implementForeignExport ( Name n )
+Text makeTypeDescrText ( Type t )
 {
-    Type t         = name(n).type;
     List argTys    = NIL;
     List resultTys = NIL;
-    Char cc_char;
+    List tdList;
 
+#if 0
+    // I don't understand what this achieves.
     if (getHead(t)==typeArrow && argCount==2) {
        t = arg(fun(t));
     } else {
-        ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
-        ERRTEXT " \"" ETHEN ERRTYPE(t);
-        ERRTEXT "\""
-        EEND;        
+        return NIL;
     }
-
+#endif
     while (getHead(t)==typeArrow && argCount==2) {
         Type ta = fullExpand(arg(fun(t)));
         Type tr = arg(t);
@@ -924,15 +906,36 @@ Void implementForeignExport ( Name n )
         assert(length(resultTys) == 1);
         resultTys = hd(resultTys);
     } else {
-        ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
-        ERRTEXT " \"" ETHEN ERRTYPE(t);
-        ERRTEXT "\""
-        EEND;        
+        return NIL;
     }
     resultTys = fullExpand(resultTys);
 
     mapOver(foreignInboundTy,argTys);
 
+    tdList = cons(mkChar(':'),argTys);
+    if (resultTys != typeUnit)
+       tdList = cons(foreignOutboundTy(resultTys),tdList);
+
+    return findText(charListToString ( tdList ));
+}
+
+
+Void implementForeignExport ( Name n )
+{
+    Text     tdText;
+    List     args;
+    StgVar   e1, e2, e3, v;
+    StgExpr  fun;
+    Char     cc_char;
+
+    tdText = makeTypeDescrText ( name(n).type );
+    if (isNull(tdText)) {
+        ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
+        ERRTEXT " \"" ETHEN ERRTYPE(name(n).type);
+        ERRTEXT "\""
+        EEND;
+    }
+
     /* ccall is the default convention, if it wasn't specified */
     if (isNull(name(n).callconv)
         || name(n).callconv == textCcall) {
@@ -948,18 +951,6 @@ Void implementForeignExport ( Name n )
     else
        internal ( "implementForeignExport: unknown calling convention");
 
-    {
-    List     tdList;
-    Text     tdText;
-    List     args;
-    StgVar   e1, e2, e3, v;
-    StgExpr  fun;
-
-    tdList = cons(mkChar(':'),argTys);
-    if (resultTys != typeUnit)
-       tdList = cons(foreignOutboundTy(resultTys),tdList);
-
-    tdText = findText(charListToString ( tdList ));
     args   = makeArgs(1);
     e1     = mkStgVar(
                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
@@ -989,7 +980,6 @@ Void implementForeignExport ( Name n )
     name(n).defn     = NIL;    
     name(n).closure  = v;
     addToCodeList ( currentModule, n );
-    }
 }
 
 Void implementTuple(size)
diff --git a/ghc/rts/ForeignCall.c b/ghc/rts/ForeignCall.c
index 080742cb2b..66e547713a 100644
--- a/ghc/rts/ForeignCall.c
+++ b/ghc/rts/ForeignCall.c
@@ -1,6 +1,6 @@
 
 /* -----------------------------------------------------------------------------
- * $Id: ForeignCall.c,v 1.15 2000/04/27 16:35:30 sewardj Exp $
+ * $Id: ForeignCall.c,v 1.16 2000/05/12 11:59:39 sewardj Exp $
  *
  * (c) The GHC Team 1994-1999.
  *
@@ -469,7 +469,7 @@ unpackArgsAndCallHaskell_x86_nocallconv_wrk ( StgStablePtr stableptr,
       sstat = rts_evalIO ( node, &nodeOut );
    } else {
       node = rts_apply ( 
-                getHugs_BCO_cptr_for("primRunST"), 
+                getHugs_BCO_cptr_for("runST"), 
                 node );
       sstat = rts_eval ( node, &nodeOut );
    }