From 9f0b4b7582b3e98ea80c20a142e1b97825c92a99 Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 12 May 2000 11:59:39 +0000 Subject: [PATCH] [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. --- ghc/includes/DietHEP.h | 11 +++ ghc/interpreter/connect.h | 5 +- ghc/interpreter/hugs.c | 166 +++++++++++++++++++++++++++++++++++-------- ghc/interpreter/translate.c | 78 +++++++++----------- ghc/rts/ForeignCall.c | 4 +- 5 files changed, 188 insertions(+), 76 deletions(-) create mode 100644 ghc/includes/DietHEP.h diff --git a/ghc/includes/DietHEP.h b/ghc/includes/DietHEP.h new file mode 100644 index 0000000..461164e --- /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 430e130..52d894a 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 79a335c..2e0b208 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 @@ -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 0ccd6eb..a4e3b9d 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 080742c..66e5477 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 ); } -- 1.7.10.4