Commit 9f0b4b75 authored by sewardj's avatar sewardj
Browse files

[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.
parent e5dfcd65
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 );
......@@ -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 */
......
......@@ -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:
......
......@@ -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)
......
/* -----------------------------------------------------------------------------
* $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 );
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment