* 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>
#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;
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:
* 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. */
*/
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");
MainDone();
}
-#endif
+#endif /* DIET_HEP */
/* --------------------------------------------------------------------------
* Initialization, interpret command line args and read prelude:
* 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"
/* ---------------------------------------------------------------- */
-#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);
case VAROPCELL:
return stgText(textOf(e),sc);
case TUPLE:
- /* return getSTGTupleVar(e); */
return e;
case NAME:
return e;
}
+
/* Generate code:
*
* \ fun ->
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);
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) {
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))),
name(n).defn = NIL;
name(n).closure = v;
addToCodeList ( currentModule, n );
- }
}
Void implementTuple(size)
projects / ghc-hetmet.git / commitdiff