* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.66 $
- * $Date: 2000/04/10 15:39:09 $
+ * $Revision: 1.78 $
+ * $Date: 2000/06/28 10:42:17 $
* ------------------------------------------------------------------------*/
#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:
static Bool showStats = FALSE; /* TRUE => print stats after eval */
static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
static Bool addType = FALSE; /* TRUE => print type with value */
-static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
static Bool lastWasObject = FALSE;
List ifaces_outstanding = NIL;
+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 "StgDLL.h"
+#include "DietHEP.h"
- console_options.top = 50;
- console_options.left = 20;
+extern void setRtsFlags ( int );
- console_options.nrows = 32;
- console_options.ncols = 80;
+static int diet_hep_initialised = 0;
+static FILE* dh_logfile;
- console_options.pause_atexit = 1;
- console_options.title = "\pHugs";
+static
+void printf_now ( void )
+{
+ time_t now = time(NULL);
+ printf("\n=== DietHEP event at %s",ctime(&now));
+}
- console_options.procID = 5;
- argc = ccommand(&argv);
-#endif
+static
+void diet_hep_initialise ( void* cstackbase )
+{
+ List modConIds; /* :: [CONID] */
+ Bool prelOK;
+ String s;
+ String fakeargv[] = { "diet_hep", "+RTS",
+ "-D0", "-RTS", NULL };
+ // GC = 32
+ // sanity = 128
+ if (diet_hep_initialised) return;
+ diet_hep_initialised = 1;
+
+ CStackBase = cstackbase;
+
+ dh_logfile = freopen("diet_hep_logfile.txt","a",stdout);
+ assert(dh_logfile);
+
+ printf_now();
+ printf("===---===---=== DietHEP initialisation ===---===---===\n\n");
+ fflush(stdout);
+
+ EnableOutput(1);
+ setInstallDir ( "diet_hep" );
+
+ /* The following copied from interpreter() */
+ setBreakAction ( HugsIgnoreBreak );
+ modConIds = initialize(sizeof(fakeargv)/sizeof(String)-1,fakeargv);
+ //setRtsFlags(4 | 128 | 32);
+ assert(isNull(modConIds));
+ setBreakAction ( HugsIgnoreBreak );
+ prelOK = loadThePrelude();
+
+ if (!prelOK) {
+ printf("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
+DH_MODULE DH_LoadLibrary_wrk ( DH_LPCSTR modname )
+{
+ Text t;
+ Module m;
+ t = findText(modname);
+ addActions ( singleton(mkCon(t)) );
+ m = findModule(t);
+ if (isModule(m)) return m; else return 0;
+}
+
+static
+void* DH_GetProcAddress_wrk ( DH_CALLCONV cconv,
+ DH_MODULE hModule,
+ DH_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;
+}
+
+/*----------- EXPORTS -------------*/
+ __attribute__((__stdcall__))
+DH_MODULE
+DH_LoadLibrary ( DH_LPCSTR modname )
+{
+ int xxx;
+ DH_MODULE hdl;
+ diet_hep_initialise ( &xxx );
+ printf_now();
+ printf("=== DH_LoadLibrary: request to load `%s'\n\n", modname );
+ fflush(stdout);
+ hdl = DH_LoadLibrary_wrk ( modname );
+ return hdl;
+}
+
+
+ __attribute__((__stdcall__))
+void*
+DH_GetProcAddress ( DH_CALLCONV cconv,
+ DH_MODULE hModule,
+ DH_LPCSTR lpProcName )
+{
+ int xxx;
+ diet_hep_initialise ( &xxx );
+ printf_now();
+ printf("=== DH_GetProcAddress: request for `%s'\n\n", lpProcName );
+ fflush(stdout);
+ return DH_GetProcAddress_wrk ( cconv, hModule, lpProcName );
+}
- CStackBase = &argc; /* Save stack base for use in gc */
-#ifdef DEBUG
#if 0
- checkBytecodeCount(); /* check for too many bytecodes */
+BOOL APIENTRY
+DllMain (
+ HINSTANCE hInst /* Library instance handle. */ ,
+ DWORD reason /* Reason this function is being called. */ ,
+ LPVOID reserved /* Not used. */ )
+{
+
+ switch (reason)
+ {
+ case DLL_PROCESS_ATTACH:
+ break;
+
+ case DLL_PROCESS_DETACH:
+ break;
+
+ case DLL_THREAD_ATTACH:
+ break;
+
+ case DLL_THREAD_DETACH:
+ break;
+ }
+ return TRUE;
+}
#endif
+
+//---------------------------------
+//--- testing it ...
+#if 0
+int main ( int argc, char** argv )
+{
+ void* proc;
+ DH_MODULE hdl;
+ hdl = DH_LoadLibrary("FooBar");
+ assert(isModule(hdl));
+ proc = DH_GetProcAddress ( 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;
+}
#endif
+#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
+ checkBytecodeCount(); /* check for too many bytecodes */
+# 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. */
if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
Printf("__ __ __ __ ____ ___ _________________________________________\n");
Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
- Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
+ Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-2000\n");
Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
*/
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:
readOptions("-p\"%s> \" -r$$");
readOptions(fromEnv("STGHUGSFLAGS",""));
-# if DEBUG
+# ifdef DEBUG
{
char exe_name[N_INSTALLDIR + 6];
strcpy(exe_name, installDir);
{":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
{":quit", QUIT}, {":set", SET}, {":find", FIND},
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
- {":dump", DUMP}, {":ztats", STATS},
- {":module",SETMODULE},
+ {":dump", DUMP},
+ {":module", SETMODULE},
{":browse", BROWSE},
#if EXPLAIN_INSTANCE_RESOLUTION
{":xplain", XPLAIN},
Printf(":gc force garbage collection\n");
Printf(":version print Hugs version\n");
Printf(":dump <name> print STG code for named fn\n");
-#ifdef CRUDE_PROFILING
- Printf(":ztats <name> print reduction stats\n");
-#endif
Printf(":quit exit Hugs interpreter\n");
}
{'g', 1, "Print no. cells recovered after gc", &gcMessages},
{'l', 1, "Literate modules as default", &literateScripts},
{'e', 1, "Warn about errors in literate modules", &literateErrors},
- {'.', 1, "Print dots to show progress", &useDots},
{'q', 1, "Print nothing to show progress", &quiet},
{'w', 1, "Always show which modules are loaded", &listScripts},
{'k', 1, "Show kind errors in full", &kindExpert},
{
HugsBreakAction tmp = currentBreakAction;
currentBreakAction = newAction;
+
+# if defined(mingw32_TARGET_OS)
+ /* Be wierd. You can't longjmp in a signal handler,
+ and posix signals are not supported.
+ */
+ if (newAction == HugsRtsInterrupt) {
+ setHandler ( handler_RtsInterrupt );
+ } else {
+ signal(SIGINT,SIG_IGN);
+ }
+# else
+ /* do it Right */
switch (newAction) {
case HugsIgnoreBreak:
setHandler ( handler_IgnoreBreak ); break;
default:
internal("setBreakAction");
}
+# endif
+
return tmp;
}
u = hd(t);
switch (whatIs(u)) {
case GRP_NONREC:
- FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
+ Printf ( " %s\n", textToStr(textOf(snd(u))));
break;
case GRP_REC:
- FPrintf ( stderr, " {" );
+ Printf ( " {" );
for (v = snd(u); nonNull(v); v=tl(v))
- FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
- FPrintf ( stderr, "}\n" );
+ Printf ( "%s ", textToStr(textOf(hd(v))) );
+ Printf ( "}\n" );
break;
default:
internal("ppMG");
}
+/* Refresh the current target modules, and attempt to set the
+ current module to what it was before (ie currentModule):
+ if currentModule_failed is different from currentModule,
+ use that instead
+ if nextCurrMod is non null, try to set it to that instead
+ if the one we're after insn't available, select a target
+ from the end of the module group list.
+*/
static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
{
List t;
- ConId tryFor = mkCon(module(currentModule).text);
+ ConId tryFor;
+
+ /* Remember what the old current module was. */
+ tryFor = mkCon(module(currentModule).text);
+
+ /* Do the Real Work. */
achieveTargetModules(FALSE);
+
+ /* Remember if the current module was invalidated by this
+ refresh, so later refreshes can attempt to reload it. */
+ if (!elemMG(tryFor))
+ currentModule_failed = tryFor;
+
+ /* If a previous refresh failed to get an old current module,
+ try for that instead. */
+ if (nonNull(currentModule_failed)
+ && textOf(currentModule_failed) != textOf(tryFor)
+ && elemMG(currentModule_failed))
+ tryFor = currentModule_failed;
+ /* If our caller specified a new current module, that overrides
+ all historical settings. */
if (nonNull(nextCurrMod))
tryFor = nextCurrMod;
+ /* Finally, if we can't actually get hold of whatever it was we
+ were after, select something which is possible. */
if (!elemMG(tryFor))
tryFor = selectLatestMG();
+
/* combined mode kludge, to get Prelude rather than PrelHugs */
if (combined && textOf(tryFor)==findText("PrelHugs"))
tryFor = mkCon(findText("Prelude"));
if (cleanAfter) {
- /* delete any targetModules which didn't actually get loaded */
- t = targetModules;
- targetModules = NIL;
- for (; nonNull(t); t=tl(t))
- if (elemMG(hd(t)))
- targetModules = cons(hd(t),targetModules);
+ /* delete any targetModules which didn't actually get loaded */
+ t = targetModules;
+ targetModules = NIL;
+ for (; nonNull(t); t=tl(t))
+ if (elemMG(hd(t)))
+ targetModules = cons(hd(t),targetModules);
}
setCurrModule ( findModule(textOf(tryFor)) );
bd = type;
if (whatIs(bd)==QUAL) {
+ printing = FALSE;
clearCurrentFile();
ERRMSG(0) "Unresolved overloading" ETHEN
ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
}
#if 1
+ printing = TRUE;
+ numEnters = 0;
if (isProgType(ks,bd)) {
inputExpr = ap(nameRunIO_toplevel,inputExpr);
evalExp();
} else {
Cell d = provePred(ks,NIL,ap(classShow,bd));
if (isNull(d)) {
- clearCurrentFile();
+ clearCurrentFile();
+ printing = FALSE;
ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
nukeModule(evalMod);
setCurrModule(currMod);
setCurrentFile(currMod);
+ stopAnyPrinting();
}
static Void local listNames() { /* list names matching optional pat*/
String pat = readFilename();
List names = NIL;
- Int width = getTerminalWidth() - 1;
+ Int width = 72;
Int count = 0;
Int termPos;
Module mod = currentModule;
case FIND : find();
break;
case LOAD : modConIds = NIL;
- while ((s=readFilename())!=0)
- modConIds = cons(mkCon(findText(s)),modConIds);
+ while ((s=readFilename())!=0) {
+ modConIds = cons(mkCon(findText(s)),modConIds);
+
+ }
loadActions(modConIds);
modConIds = NIL;
break;
break;
case SET : set();
break;
- case STATS:
-#ifdef CRUDE_PROFILING
- cp_show();
-#endif
- break;
case SYSTEM : if (shellEsc(readLine()))
Printf("Warning: Shell escape terminated abnormally\n");
break;
#endif
currTarget = (t?t:1);
aiming = TRUE;
- if (useDots) {
- currPos = strlen(what);
- maxPos = getTerminalWidth() - 1;
- Printf("%s",what);
- }
- else
- for (charCount=0; *what; charCount++)
- Putchar(*what++);
+ for (charCount=0; *what; charCount++)
+ Putchar(*what++);
FlushStdout();
}
if (showInstRes)
return;
#endif
- if (useDots) {
- Int newPos = (Int)((maxPos * ((long)t))/currTarget);
-
- if (newPos>maxPos)
- newPos = maxPos;
-
- if (newPos>currPos) {
- do
- Putchar('.');
- while (newPos>++currPos);
- FlushStdout();
- }
- FlushStdout();
- }
}
Void done() { /* Goal has now been achieved */
if (showInstRes)
return;
#endif
- if (useDots) {
- while (maxPos>currPos++)
- Putchar('.');
- Putchar('\n');
+ for (; charCount>0; charCount--) {
+ Putchar('\b');
+ Putchar(' ');
+ Putchar('\b');
}
- else
- for (; charCount>0; charCount--) {
- Putchar('\b');
- Putchar(' ');
- Putchar('\b');
- }
aiming = FALSE;
FlushStdout();
}
Putchar('\n');
if (showStats) {
#define plural(v) v, (v==1?"":"s")
- Printf("%lu cell%s",plural(numCells));
- if (numGcs>0)
- Printf(", %u garbage collection%s",plural(numGcs));
- Printf(")\n");
+ Printf("(%lu enter%s)\n",plural(numEnters));
#undef plural
}
FlushStdout();
typeChecker(what);
compiler(what);
codegen(what);
-
- mark(moduleGraph);
- mark(prelModules);
- mark(targetModules);
- mark(daSccs);
+ interfayce(what);
+
+ if (what == MARK) {
+ mark(moduleGraph);
+ mark(prelModules);
+ mark(targetModules);
+ mark(daSccs);
+ mark(currentModule_failed);
+ }
}
/*-------------------------------------------------------------------------*/