X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fhugs.c;h=e2507bcaf4d97f1f8b929d77e07a47c932147888;hb=e4706792d290d4c5cb6a020d2973689efb7457ff;hp=4292db85e251fcaff7d06157ab2cf5710ed351e9;hpb=1d4102fe665c0e9d6594d9195ac540466b2e7683;p=ghc-hetmet.git diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 4292db8..e2507bc 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,22 +9,19 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.34 $ - * $Date: 2000/01/10 16:27:03 $ + * $Revision: 1.67 $ + * $Date: 2000/04/17 11:39:23 $ * ------------------------------------------------------------------------*/ #include #include #include -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "command.h" -#include "backend.h" #include "connect.h" #include "errors.h" #include "version.h" -#include "link.h" #include "Rts.h" #include "RtsAPI.h" @@ -32,6 +29,7 @@ #include "Assembler.h" /* DEBUG_LoadSymbols */ Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/ +Bool initDone = FALSE; #if EXPLAIN_INSTANCE_RESOLUTION Bool showInstRes = FALSE; @@ -44,65 +42,52 @@ Bool multiInstRes = FALSE; * Local function prototypes: * ------------------------------------------------------------------------*/ -static Void local initialize Args((Int,String [])); -static Void local promptForInput Args((String)); -static Void local interpreter Args((Int,String [])); -static Void local menu Args((Void)); -static Void local guidance Args((Void)); -static Void local forHelp Args((Void)); -static Void local set Args((Void)); -static Void local changeDir Args((Void)); -static Void local load Args((Void)); -static Void local project Args((Void)); -static Void local readScripts Args((Int)); -static Void local whatScripts Args((Void)); -static Void local editor Args((Void)); -static Void local find Args((Void)); -static Bool local startEdit Args((Int,String)); -static Void local runEditor Args((Void)); -static Void local setModule Args((Void)); -static Module local findEvalModule Args((Void)); -static Void local evaluator Args((Void)); -static Void local stopAnyPrinting Args((Void)); -static Void local showtype Args((Void)); -static String local objToStr Args((Module, Cell)); -static Void local info Args((Void)); -static Void local printSyntax Args((Name)); -static Void local showInst Args((Inst)); -static Void local describe Args((Text)); -static Void local listNames Args((Void)); - -static Void local toggleSet Args((Char,Bool)); -static Void local togglesIn Args((Bool)); -static Void local optionInfo Args((Void)); -#if USE_REGISTRY || HUGS_FOR_WINDOWS -static String local optionsToStr Args((Void)); -#endif -static Void local readOptions Args((String)); -static Bool local processOption Args((String)); -static Void local setHeapSize Args((String)); -static Int local argToInt Args((String)); - -static Void local loadProject Args((String)); -static Void local clearProject Args((Void)); -static Bool local addScript Args((Int)); -static Void local forgetScriptsFrom Args((Script)); -static Void local setLastEdit Args((String,Int)); -static Void local failed Args((Void)); -static String local strCopy Args((String)); -static Void local browseit Args((Module,String,Bool)); -static Void local browse Args((Void)); +static List local initialize ( Int,String [] ); +static Void local promptForInput ( String ); +static Void local interpreter ( Int,String [] ); +static Void local menu ( Void ); +static Void local guidance ( Void ); +static Void local forHelp ( Void ); +static Void local set ( Void ); +static Void local changeDir ( Void ); +static Void local load ( Void ); +static Void local project ( Void ); +static Void local editor ( Void ); +static Void local find ( Void ); +static Bool local startEdit ( Int,String ); +static Void local runEditor ( Void ); +static Void local setModule ( Void ); +static Void local evaluator ( Void ); +static Void local stopAnyPrinting ( Void ); +static Void local showtype ( Void ); +static String local objToStr ( Module, Cell ); +static Void local info ( Void ); +static Void local printSyntax ( Name ); +static Void local showInst ( Inst ); +static Void local describe ( Text ); +static Void local listNames ( Void ); + +static Void local toggleSet ( Char,Bool ); +static Void local togglesIn ( Bool ); +static Void local optionInfo ( Void ); +static Void local readOptions ( String ); +static Bool local processOption ( String ); +static Void local setHeapSize ( String ); +static Int local argToInt ( String ); + +static Void local setLastEdit ( String,Int ); +static Void local failed ( Void ); +static String local strCopy ( String ); +static Void local browseit ( Module,String,Bool ); +static Void local browse ( Void ); +static void local clearCurrentFile ( void ); + /* -------------------------------------------------------------------------- * Machine dependent code for Hugs interpreter: * ------------------------------------------------------------------------*/ - Bool combined = TRUE; - #include "machdep.c" -#ifdef WANT_TIMER -#include "timer.c" -#endif /* -------------------------------------------------------------------------- * Local data areas: @@ -115,89 +100,31 @@ 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; + + Bool flagAssert = FALSE; /* TRUE => assert False causes + an assertion failure */ Bool preludeLoaded = FALSE; Bool debugSC = FALSE; + Bool combined = FALSE; -typedef - struct { - String modName; /* Module name */ - Bool details; /* FALSE => remaining fields are invalid */ - String path; /* Path to module */ - String srcExt; /* ".hs" or ".lhs" if fromSource */ - Time lastChange; /* Time of last change to script */ - Bool fromSource; /* FALSE => load object code */ - Bool postponed; /* Indicates postponed load */ - Bool objLoaded; - Long size; - Long oSize; - } - ScriptInfo; - -static Void local makeStackEntry Args((ScriptInfo*,String)); -static Void local addStackEntry Args((String)); - -static ScriptInfo scriptInfo[NUM_SCRIPTS]; - -static Int numScripts; /* Number of scripts loaded */ -static Int nextNumScripts; -static Int namesUpto; /* Number of script names set */ -static Bool needsImports; /* set to TRUE if imports required */ - String scriptFile; /* Name of current script (if any) */ - - - -static Text evalModule = 0; /* Name of module we eval exprs in */ -static String currProject = 0; /* Name of current project file */ -static Bool projectLoaded = FALSE; /* TRUE => project file loaded */ + Module moduleBeingParsed; /* so the parser (topModule) knows */ +static char* currentFile; /* Name of current file, or NULL */ +static char currentFileName[1000]; /* name is stored here if it exists*/ static Bool autoMain = FALSE; static String lastEdit = 0; /* Name of script to edit (if any) */ static Int lastEdLine = 0; /* Editor line number (if possible)*/ static String prompt = 0; /* Prompt string */ static Int hpSize = DEFAULTHEAP; /* Desired heap size */ +static Bool disableOutput = FALSE; /* TRUE => quiet */ String hugsEdit = 0; /* String for editor command */ String hugsPath = 0; /* String for file search path */ List ifaces_outstanding = NIL; -#if REDIRECT_OUTPUT -static Bool disableOutput = FALSE; /* redirect output to buffer? */ -#endif +static ConId currentModule_failed = NIL; /* Remember failed module from :r */ -String bool2str ( Bool b ) -{ - if (b) return "Yes"; else return "No "; -} -void ppSmStack ( String who ) -{ - int i, j; -return; - fflush(stdout);fflush(stderr); - printf ( "\n" ); - printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n", - who, numScripts, namesUpto, bool2str(needsImports) ); - assert (namesUpto >= numScripts); - printf ( " Det FrS Pst ObL Module Ext Size ModTime Path\n" ); - for (i = namesUpto-1; i >= 0; i--) { - printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n", - (i==numScripts ? '*' : ' '), - i, bool2str(scriptInfo[i].details), - bool2str(scriptInfo[i].fromSource), - bool2str(scriptInfo[i].postponed), - bool2str(scriptInfo[i].objLoaded), - scriptInfo[i].modName, - scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "", - scriptInfo[i].size, - scriptInfo[i].lastChange, - scriptInfo[i].path - ); - } - fflush(stdout);fflush(stderr); - ppScripts(); - ppModules(); - printf ( "\n" ); -} /* -------------------------------------------------------------------------- * Hugs entry point: @@ -205,7 +132,7 @@ return; #ifndef NO_MAIN /* we omit main when building the "Hugs server" */ -Main main Args((Int, String [])); /* now every func has a prototype */ +Main main ( Int, String [] ); /* now every func has a prototype */ Main main(argc,argv) int argc; @@ -229,12 +156,18 @@ 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)) { autoMain = TRUE; if (strcmp(argv[1],"-Q") == 0) { - hugsEnableOutput(0); + EnableOutput(0); } } @@ -272,111 +205,95 @@ char *argv[]; { * Initialization, interpret command line args and read prelude: * ------------------------------------------------------------------------*/ -static Void local initialize(argc,argv)/* Interpreter initialization */ -Int argc; -String argv[]; { - Script i; - String proj = 0; - char argv_0_orig[1000]; - - setLastEdit((String)0,0); - lastEdit = 0; - scriptFile = 0; - numScripts = 0; - namesUpto = 1; - -#if HUGS_FOR_WINDOWS - hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe")); -#elif SYMANTEC_C - hugsEdit = ""; +static List /*CONID*/ initialize ( Int argc, String argv[] ) +{ + Int i, j; + List initialModules; + + setLastEdit((String)0,0); + lastEdit = 0; + currentFile = NULL; + +#if SYMANTEC_C + hugsEdit = ""; #else - hugsEdit = strCopy(fromEnv("EDITOR",NULL)); + hugsEdit = strCopy(fromEnv("EDITOR",NULL)); #endif - hugsPath = strCopy(HUGSPATH); - readOptions("-p\"%s> \" -r$$"); -#if USE_REGISTRY - projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot, - "HUGSPATH", PATHSEP, "")); - readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options","")); - readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options","")); -#endif /* USE_REGISTRY */ - readOptions(fromEnv("STGHUGSFLAGS","")); - - strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */ - startupHaskell (argc,argv); - argc = prog_argc; argv = prog_argv; - - namesUpto = numScripts = 0; - - /* Pre-scan flags to see if -c or +c is present. This needs to - precede adding the stack entry for Prelude. On the other hand, - that stack entry needs to be made before the cmd line args are - properly examined. Hence the following pre-scan of them. + hugsPath = strCopy(HUGSPATH); + readOptions("-p\"%s> \" -r$$"); + readOptions(fromEnv("STGHUGSFLAGS","")); + +# if DEBUG + { + char exe_name[N_INSTALLDIR + 6]; + strcpy(exe_name, installDir); + strcat(exe_name, "hugs"); + DEBUG_LoadSymbols(exe_name); + } +# endif + + /* startupHaskell extracts args between +RTS ... -RTS, and sets + prog_argc/prog_argv to the rest. We want to further process + the rest, so we then get hold of them again. */ - for (i=1; i < argc; ++i) { + startupHaskell ( argc, argv, NULL ); + getProgArgv ( &argc, &argv ); + + /* Find out early on if we're in combined mode or not. + everybody(PREPREL) needs to know this. Also, establish the + heap size; + */ + for (i = 1; i < argc; ++i) { if (strcmp(argv[i], "--")==0) break; if (strcmp(argv[i], "-c")==0) combined = FALSE; if (strcmp(argv[i], "+c")==0) combined = TRUE; - } - addStackEntry("Prelude"); + if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0) + setHeapSize(&(argv[i][2])); + } - for (i=1; i < argc; ++i) { /* process command line arguments */ - if (strcmp(argv[i], "--")==0) break; - if (strcmp(argv[i],"+")==0 && i+11) { - fprintf(stderr, - "\nUsing project file, ignoring additional filenames\n"); - } - loadProject(strCopy(proj)); - } - readScripts(0); + initDone = TRUE; + return initialModules; } /* -------------------------------------------------------------------------- @@ -400,8 +317,9 @@ Bool state; { *toggle[i].flag = state; return; } + clearCurrentFile(); ERRMSG(0) "Unknown toggle `%c'", c - EEND; + EEND_NO_LONGJMP; } static Void local togglesIn(state) /* Print current list of toggles in*/ @@ -470,65 +388,6 @@ ToDo Putchar('\n'); } -#if USE_REGISTRY || HUGS_FOR_WINDOWS -#define PUTC(c) \ - *next++=(c) - -#define PUTS(s) \ - strcpy(next,s); \ - next+=strlen(next) - -#define PUTInt(optc,i) \ - sprintf(next,"-%c%d",optc,i); \ - next+=strlen(next) - -#define PUTStr(c,s) \ - next=PUTStr_aux(next,c,s) - -static String local PUTStr_aux Args((String,Char, String)); - -static String local PUTStr_aux(next,c,s) -String next; -Char c; -String s; { - if (s) { - String t = 0; - sprintf(next,"-%c\"",c); - next+=strlen(next); - for(t=s; *t; ++t) { - PUTS(unlexChar(*t,'"')); - } - next+=strlen(next); - PUTS("\" "); - } - return next; -} - -static String local optionsToStr() { /* convert options to string */ - static char buffer[2000]; - String next = buffer; - - Int i; - for (i=0; toggle[i].c; ++i) { - PUTC(*toggle[i].flag ? '+' : '-'); - PUTC(toggle[i].c); - PUTC(' '); - } - PUTS(haskell98 ? "+98 " : "-98 "); - PUTInt('h',hpSize); PUTC(' '); - PUTStr('p',prompt); - PUTStr('r',repeatStr); - PUTStr('P',hugsPath); - PUTStr('E',hugsEdit); - PUTInt('c',cutoff); PUTC(' '); -#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN)) - PUTStr('F',preprocessor); -#endif - PUTC('\0'); - return buffer; -} -#endif /* USE_REGISTRY */ - #undef PUTC #undef PUTS #undef PUTInt @@ -592,17 +451,12 @@ String s; { /* return FALSE if none found. */ return TRUE; #endif - case 'h' : setHeapSize(s+1); + case 'h' : /* don't do anything, since pre-scan of args + will have got it already */ return TRUE; - case 'c' : if (heapBuilt()) { - FPrintf(stderr, - "You can't enable/disable combined" - " operation inside Hugs\n" ); - } else { - /* don't do anything, since pre-scan of args - will have got it already */ - } + case 'c' : /* don't do anything, since pre-scan of args + will have got it already */ return TRUE; case 'D' : /* hack */ @@ -613,7 +467,7 @@ String s; { /* return FALSE if none found. */ } default : if (strcmp("98",s)==0) { - if (heapBuilt() && ((state && !haskell98) || + if (initDone && ((state && !haskell98) || (!state && haskell98))) { FPrintf(stderr, "Haskell 98 compatibility cannot be changed" @@ -638,13 +492,9 @@ String s; { hpSize = MINIMUMHEAP; else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP) hpSize = MAXIMUMHEAP; - if (heapBuilt() && hpSize != heapSize) { + if (initDone && hpSize != heapSize) { /* ToDo: should this use a message box in winhugs? */ -#if USE_REGISTRY - FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n"); -#else FPrintf(stderr,"You cannot change heap size from inside Hugs\n"); -#endif } else { heapSize = hpSize; } @@ -788,21 +638,14 @@ struct options toggle[] = { /* List of command line toggles */ {'w', 1, "Always show which modules are loaded", &listScripts}, {'k', 1, "Show kind errors in full", &kindExpert}, {'o', 0, "Allow overlapping instances", &allowOverlap}, - - -#if DEBUG_CODE - {'D', 1, "Debug: show generated code", &debugCode}, -#endif + {'S', 1, "Debug: show generated SC code", &debugSC}, + {'a', 1, "Raise exception on assert failure", &flagAssert}, #if EXPLAIN_INSTANCE_RESOLUTION {'x', 1, "Explain instance resolution", &showInstRes}, #endif #if MULTI_INST {'m', 0, "Use multi instance resolution", &multiInstRes}, #endif -#if DEBUG_CODE - {'D', 1, "Debug: show generated G code", &debugCode}, -#endif - {'S', 1, "Debug: show generated SC code", &debugSC}, {0, 0, 0, 0} }; @@ -813,12 +656,9 @@ static Void local set() { /* change command line options from*/ do { if (!processOption(s)) { ERRMSG(0) "Option string must begin with `+' or `-'" - EEND; + EEND_NO_LONGJMP; } } while ((s=readFilename())!=0); -#if USE_REGISTRY - writeRegString("Options", optionsToStr()); -#endif } else optionInfo(); @@ -832,467 +672,965 @@ static Void local changeDir() { /* change directory */ String s = readFilename(); if (s && chdir(s)) { ERRMSG(0) "Unable to change to directory \"%s\"", s - EEND; + EEND_NO_LONGJMP; } } + /* -------------------------------------------------------------------------- - * Loading project and script files: + * Interrupt handling * ------------------------------------------------------------------------*/ -static Void local loadProject(s) /* Load project file */ -String s; { - clearProject(); - currProject = s; - projInput(currProject); - scriptFile = currProject; - forgetScriptsFrom(1); - while ((s=readFilename())!=0) - addStackEntry(s); - if (namesUpto<=1) { - ERRMSG(0) "Empty project file" - EEND; - } - scriptFile = 0; - projectLoaded = TRUE; -} +static jmp_buf catch_error; /* jump buffer for error trapping */ -static Void local clearProject() { /* clear name for current project */ - if (currProject) - free(currProject); - currProject = 0; - projectLoaded = FALSE; -#if HUGS_FOR_WINDOWS - setLastEdit((String)0,0); -#endif -} +HugsBreakAction currentBreakAction = HugsIgnoreBreak; +static void handler_IgnoreBreak ( int sig ) +{ + setHandler ( handler_IgnoreBreak ); +} +static void handler_LongjmpOnBreak ( int sig ) +{ + setHandler ( handler_LongjmpOnBreak ); + Printf("{Interrupted!}\n"); + longjmp(catch_error,1); +} -static Void local makeStackEntry ( ScriptInfo* ent, String iname ) +static void handler_RtsInterrupt ( int sig ) { - Bool ok, fromObj; - Bool sAvail, iAvail, oAvail; - Time sTime, iTime, oTime; - Long sSize, iSize, oSize; - String path, sExt; + setHandler ( handler_RtsInterrupt ); + interruptStgRts(); +} - ok = findFilesForModule ( - iname, - &path, - &sExt, - &sAvail, &sTime, &sSize, - &iAvail, &iTime, &iSize, - &oAvail, &oTime, &oSize - ); - if (!ok) { - ERRMSG(0) - "Can't find source or object+interface for module \"%s\"", - /* "Can't find source for module \"%s\"", */ - iname - EEND; +HugsBreakAction setBreakAction ( HugsBreakAction newAction ) +{ + HugsBreakAction tmp = currentBreakAction; + currentBreakAction = newAction; + switch (newAction) { + case HugsIgnoreBreak: + setHandler ( handler_IgnoreBreak ); break; + case HugsLongjmpOnBreak: + setHandler ( handler_LongjmpOnBreak ); break; + case HugsRtsInterrupt: + setHandler ( handler_RtsInterrupt ); break; + default: + internal("setBreakAction"); } - /* findFilesForModule should enforce this */ - if (!(sAvail || (oAvail && iAvail))) - internal("chase"); - /* Load objects in preference to sources if both are available */ - /* 11 Oct 99: disable object loading in the interim. - Will probably only reinstate when HEP becomes available. - */ - if (combined) { - fromObj = sAvail - ? (oAvail && iAvail && timeEarlier(sTime,oTime)) - : TRUE; - } else { - fromObj = FALSE; + return tmp; +} + + +/* -------------------------------------------------------------------------- + * The new module chaser, loader, etc + * ------------------------------------------------------------------------*/ + +List moduleGraph = NIL; +List prelModules = NIL; +List targetModules = NIL; + +static String modeToString ( Cell mode ) +{ + switch (mode) { + case FM_SOURCE: return "source"; + case FM_OBJECT: return "object"; + case FM_EITHER: return "source or object"; + default: internal("modeToString"); } +} - /* ToDo: namesUpto overflow */ - ent->modName = strCopy(iname); - ent->details = TRUE; - ent->path = path; - ent->fromSource = !fromObj; - ent->srcExt = sExt; - ent->postponed = FALSE; - ent->lastChange = sTime; /* ToDo: is this right? */ - ent->size = fromObj ? iSize : sSize; - ent->oSize = fromObj ? oSize : 0; - ent->objLoaded = FALSE; +static Cell childMode ( Cell modeMeRequest, Cell modeMeActual ) +{ + assert(modeMeActual == FM_SOURCE || + modeMeActual == FM_OBJECT); + assert(modeMeRequest == FM_SOURCE || + modeMeRequest == FM_OBJECT || + modeMeRequest == FM_EITHER); + if (modeMeRequest == FM_SOURCE) return modeMeRequest; + if (modeMeRequest == FM_OBJECT) return modeMeRequest; + if (modeMeActual == FM_OBJECT) return FM_OBJECT; + if (modeMeActual == FM_SOURCE) return FM_EITHER; + internal("childMode"); +} + +static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting ) +{ + if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE; + if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE; + if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE; + if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE; + return FALSE; } +static void setCurrentFile ( Module mod ) +{ + assert(isModule(mod)); + strncpy(currentFileName, textToStr(module(mod).text), 990); + strcat(currentFileName, textToStr(module(mod).srcExt)); + currentFile = currentFileName; + moduleBeingParsed = mod; +} +static void clearCurrentFile ( void ) +{ + currentFile = NULL; + moduleBeingParsed = NIL; +} -static Void nukeEnding( String s ) +static void ppMG ( void ) { - Int l = strlen(s); - if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else - if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else - if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else - if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else - if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else - if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0; -} - -static Void local addStackEntry(s) /* Add script to list of scripts */ -String s; { /* to be read in ... */ - String s2; - Bool found; - Int i; + List t,u,v; + for (t = moduleGraph; nonNull(t); t=tl(t)) { + u = hd(t); + switch (whatIs(u)) { + case GRP_NONREC: + FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u)))); + break; + case GRP_REC: + FPrintf ( stderr, " {" ); + for (v = snd(u); nonNull(v); v=tl(v)) + FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) ); + FPrintf ( stderr, "}\n" ); + break; + default: + internal("ppMG"); + } + } +} - if (namesUpto>=NUM_SCRIPTS) { - ERRMSG(0) "Too many module files (maximum of %d allowed)", - NUM_SCRIPTS - EEND; - } - s = strCopy(s); - nukeEnding(s); - for (s2 = s; *s2; s2++) - if (*s2 == SLASH && *(s2+1)) s = s2+1; +static Bool elemMG ( ConId mod ) +{ + List gs; + for (gs = moduleGraph; nonNull(gs); gs=tl(gs)) + switch (whatIs(hd(gs))) { + case GRP_NONREC: + if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE; + break; + case GRP_REC: + if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE; + break; + default: + internal("elemMG"); + } + return FALSE; +} + - found = FALSE; - for (i = 0; i < namesUpto; i++) - if (strcmp(scriptInfo[i].modName,s)==0) - found = TRUE; +static ConId selectArbitrarilyFromGroup ( Cell group ) +{ + switch (whatIs(group)) { + case GRP_NONREC: return snd(group); + case GRP_REC: return hd(snd(group)); + default: internal("selectArbitrarilyFromGroup"); + } +} - if (!found) { - makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) ); - namesUpto++; - } - free(s); +static ConId selectLatestMG ( void ) +{ + List gs = moduleGraph; + if (isNull(gs)) internal("selectLatestMG(1)"); + while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs); + return selectArbitrarilyFromGroup(hd(gs)); } -/* Return TRUE if no imports were needed; FALSE otherwise. */ -static Bool local addScript(stacknum) /* read single file */ -Int stacknum; { - Bool didPrelude; - static char name[FILENAME_MAX+1]; - Int len = scriptInfo[stacknum].size; -#if HUGS_FOR_WINDOWS /* Set clock cursor while loading */ - allowBreak(); - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif +static List /* of CONID */ listFromSpecifiedMG ( List mg ) +{ + List gs; + List cs = NIL; + for (gs = mg; nonNull(gs); gs=tl(gs)) { + switch (whatIs(hd(gs))) { + case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break; + case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break; + default: internal("listFromSpecifiedMG"); + } + } + return cs; +} - // setLastEdit(name,0); +static List /* of CONID */ listFromMG ( void ) +{ + return listFromSpecifiedMG ( moduleGraph ); +} - strcpy(name, scriptInfo[stacknum].path); - strcat(name, scriptInfo[stacknum].modName); - if (scriptInfo[stacknum].fromSource) - strcat(name, scriptInfo[stacknum].srcExt); else - strcat(name, ".u_hi"); - scriptFile = name; +/* Calculate the strongly connected components of modgList + and assign them to moduleGraph. Uses the .uses field of + each of the modules to build the graph structure. +*/ +#define SCC modScc /* make scc algorithm for StgVars */ +#define LOWLINK modLowlink +#define DEPENDS(t) snd(t) +#define SETDEPENDS(c,v) snd(c)=v +#include "scc.c" +#undef SETDEPENDS +#undef DEPENDS +#undef LOWLINK +#undef SCC + +static void mgFromList ( List /* of CONID */ modgList ) +{ + List t; + List u; + Text mT; + List usesT; + List adjList; /* :: [ (Text, [Text]) ] */ + Module mod; + List scc; + Bool isRec; + + adjList = NIL; + for (t = modgList; nonNull(t); t=tl(t)) { + mT = textOf(hd(t)); + mod = findModule(mT); + assert(nonNull(mod)); + usesT = NIL; + for (u = module(mod).uses; nonNull(u); u=tl(u)) + usesT = cons(textOf(hd(u)),usesT); + + /* artificially give all modules a dependency on Prelude */ + if (mT != textPrelude && mT != textPrelPrim) + usesT = cons(textPrelude,usesT); + adjList = cons(pair(mT,usesT),adjList); + } - if (scriptInfo[stacknum].fromSource) { - if (lastWasObject) { - didPrelude = processInterfaces(); - if (didPrelude) { - preludeLoaded = TRUE; - everybody(POSTPREL); + /* adjList is now [ (module-text, [modules-which-i-import-text]) ]. + Modify this so that the adjacency list is a list of pointers + back to bits of adjList -- that's what modScc needs. + */ + for (t = adjList; nonNull(t); t=tl(t)) { + List adj = NIL; + /* for each elem of the adjacency list ... */ + for (u = snd(hd(t)); nonNull(u); u=tl(u)) { + List v; + Text a = hd(u); + /* find the element of adjList whose fst is a */ + for (v = adjList; nonNull(v); v=tl(v)) { + assert(isText(a)); + assert(isText(fst(hd(v)))); + if (fst(hd(v))==a) break; } + if (isNull(v)) internal("mgFromList"); + adj = cons(hd(v),adj); } - lastWasObject = FALSE; - Printf("Reading script \"%s\":\n",name); - needsImports = FALSE; - parseScript(name,len); - if (needsImports) return FALSE; - checkDefns(); - typeCheckDefns(); - compileDefns(); - } else { - Cell iface; - List imports; - ZTriple iface_info; - char nameObj[FILENAME_MAX+1]; - Int sizeObj; + snd(hd(t)) = adj; + } + + adjList = modScc ( adjList ); + /* adjList is now [ [(module-text, aux-info-field)] ] */ + + moduleGraph = NIL; + + for (t = adjList; nonNull(t); t=tl(t)) { + + scc = hd(t); + /* scc :: [ (module-text, aux-info-field) ] */ + for (u = scc; nonNull(u); u=tl(u)) + hd(u) = mkCon(fst(hd(u))); + + /* scc :: [CONID] */ + if (length(scc) > 1) { + isRec = TRUE; + } else { + /* singleton module in scc; does it import itself? */ + mod = findModule ( textOf(hd(scc)) ); + assert(nonNull(mod)); + isRec = FALSE; + for (u = module(mod).uses; nonNull(u); u=tl(u)) + if (textOf(hd(u))==textOf(hd(scc))) + isRec = TRUE; + } + + if (isRec) + moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else + moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph ); + } + moduleGraph = reverse(moduleGraph); +} - Printf("Reading iface \"%s\":\n", name); - scriptFile = name; - needsImports = FALSE; - // set nameObj for the benefit of openGHCIface - strcpy(nameObj, scriptInfo[stacknum].path); - strcat(nameObj, scriptInfo[stacknum].modName); - strcat(nameObj, DLL_ENDING); - sizeObj = scriptInfo[stacknum].oSize; +static List /* of CONID */ getModuleImports ( Cell tree ) +{ + Cell te; + List tes; + ConId use; + List uses = NIL; + for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) { + te = hd(tes); + switch(whatIs(te)) { + case M_IMPORT_Q: + use = zfst(unap(M_IMPORT_Q,te)); + assert(isCon(use)); + if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses ); + break; + case M_IMPORT_UNQ: + use = zfst(unap(M_IMPORT_UNQ,te)); + assert(isCon(use)); + if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses ); + break; + default: + break; + } + } + return uses; +} - iface = readInterface(name,len); - imports = zsnd(iface); iface = zfst(iface); - if (nonNull(imports)) chase(imports); - scriptFile = 0; - lastWasObject = TRUE; +static void processModule ( Module m ) +{ + Cell tree; + ConId modNm; + List topEnts; + List tes; + Cell te; + Cell te2; + + tyconDefns = NIL; + typeInDefns = NIL; + valDefns = NIL; + classDefns = NIL; + instDefns = NIL; + selDefns = NIL; + genDefns = NIL; + unqualImports = NIL; + foreignImports = NIL; + foreignExports = NIL; + defaultDefns = NIL; + defaultLine = 0; + inputExpr = NIL; + + setCurrentFile(m); + startModule(m); + tree = unap(M_MODULE,module(m).tree); + modNm = zfst3(tree); + + if (textOf(modNm) != module(m).text) { + ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"", + textToStr(textOf(modNm)), + textToStr(module(m).text), + textToStr(module(m).srcExt) + EEND; + } - iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) ); - ifaces_outstanding = cons(iface_info,ifaces_outstanding); + setExportList(zsnd3(tree)); + topEnts = zthd3(tree); - if (needsImports) return FALSE; + for (tes = topEnts; nonNull(tes); tes=tl(tes)) { + te = hd(tes); + assert(isGenPair(te)); + te2 = snd(te); + switch(whatIs(te)) { + case M_IMPORT_Q: + addQualImport(zfst(te2),zsnd(te2)); + break; + case M_IMPORT_UNQ: + addUnqualImport(zfst(te2),zsnd(te2)); + break; + case M_TYCON: + tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_CLASS: + classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_INST: + instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2)); + break; + case M_DEFAULT: + defaultDefn(intOf(zfst(te2)),zsnd(te2)); + break; + case M_FOREIGN_IM: + foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + break; + case M_FOREIGN_EX: + foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + case M_VALUE: + valDefns = cons(te2,valDefns); + break; + default: + internal("processModule"); + } } - - scriptFile = 0; - - return TRUE; -} - - -Bool chase(imps) /* Process list of import requests */ -List imps; { - Int dstPosn; - ScriptInfo tmp; - Int origPos = numScripts; /* keep track of original position */ - String origName = scriptInfo[origPos].modName; - for (; nonNull(imps); imps=tl(imps)) { - String iname = textToStr(textOf(hd(imps))); - Int i = 0; - for (; i=origPos) { /* Neither loaded or queued */ - String theName; - Time theTime; - Bool thePost; - Bool theFS; - needsImports = TRUE; - if (scriptInfo[origPos].fromSource) - scriptInfo[origPos].postponed = TRUE; +static Module parseModuleOrInterface ( ConId mc, Cell modeRequest ) +{ + /* Allocate a module-table entry. */ + /* Parse the entity and fill in the .tree and .uses entries. */ + String path; + String sExt; + Bool sAvail; Time sTime; Long sSize; + Bool oiAvail; Time oiTime; Long oSize; Long iSize; + Bool ok; + Bool useSource; + char name[10000]; + + Text mt = textOf(mc); + Module mod = findModule ( mt ); + + /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n", + textToStr(mt),mod); */ + if (nonNull(mod) && !module(mod).fake) + internal("parseModuleOrInterface"); + if (nonNull(mod)) + module(mod).fake = FALSE; + + if (isNull(mod)) + mod = newModule(mt); + + /* This call malloc-ates path; we should deallocate it. */ + ok = findFilesForModule ( + textToStr(module(mod).text), + &path, + &sExt, + &sAvail, &sTime, &sSize, + &oiAvail, &oiTime, &oSize, &iSize + ); - if (i==namesUpto) { /* Name not found (i==namesUpto) */ - /* Find out where it lives, whether source or object, etc */ - makeStackEntry ( &scriptInfo[i], iname ); - namesUpto++; - } - else - if (scriptInfo[i].postponed && scriptInfo[i].fromSource) { - /* Check for recursive dependency */ - ERRMSG(0) - "Recursive import dependency between \"%s\" and \"%s\"", - scriptInfo[origPos].modName, iname - EEND; - } - /* Move stack entry i to somewhere below origPos. If i denotes - * an object, destination is immediately below origPos. - * Otherwise, it's underneath the queue of objects below origPos. - */ - dstPosn = origPos-1; - if (scriptInfo[i].fromSource) - while (!scriptInfo[dstPosn].fromSource && dstPosn > 0) - dstPosn--; - - dstPosn++; - tmp = scriptInfo[i]; - for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1]; - scriptInfo[dstPosn] = tmp; - if (dstPosn < nextNumScripts) nextNumScripts = dstPosn; - origPos++; - } - } - return needsImports; -} + if (!ok) goto cant_find; + if (!sAvail && !oiAvail) goto cant_find; + + /* Find out whether to use source or object. */ + switch (modeRequest) { + case FM_SOURCE: + if (!sAvail) goto cant_find; + useSource = TRUE; + break; + case FM_OBJECT: + if (!oiAvail) goto cant_find; + useSource = FALSE; + break; + case FM_EITHER: + if ( sAvail && !oiAvail) { useSource = TRUE; break; } + if (!sAvail && oiAvail) { useSource = FALSE; break; } + useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE; + break; + default: + internal("parseModuleOrInterface"); + } -static Void local forgetScriptsFrom(scno)/* remove scripts from system */ -Script scno; { - Script i; -#if 0 - for (i=scno; inamesUpto) - numScripts = scno; + /* Actually do the parsing. */ + if (useSource) { + module(mod).srcExt = findText(sExt); + setCurrentFile(mod); + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, sExt); + module(mod).tree = parseModule(name,sSize); + module(mod).uses = getModuleImports(module(mod).tree); + module(mod).mode = FM_SOURCE; + module(mod).lastStamp = sTime; + } else { + module(mod).srcExt = findText(HI_ENDING); + setCurrentFile(mod); + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, DLL_ENDING); + module(mod).objName = findText(name); + module(mod).objSize = oSize; + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, ".u_hi"); + module(mod).tree = parseInterface(name,iSize); + module(mod).uses = getInterfaceImports(module(mod).tree); + module(mod).mode = FM_OBJECT; + module(mod).lastStamp = oiTime; + } + + if (path) free(path); + return mod; + + cant_find: + if (path) free(path); + clearCurrentFile(); + ERRMSG(0) + "Can't find %s for module \"%s\"", + modeToString(modeRequest), textToStr(mt) + EEND; } -/* -------------------------------------------------------------------------- - * Commands for loading and removing script files: - * ------------------------------------------------------------------------*/ -static Void local load() { /* read filenames from command line */ - String s; /* and add to list of scripts waiting */ - /* to be read */ - while ((s=readFilename())!=0) - addStackEntry(s); - readScripts(1); +static void tryLoadGroup ( Cell grp ) +{ + Module m; + List t; + switch (whatIs(grp)) { + case GRP_NONREC: + m = findModule(textOf(snd(grp))); + assert(nonNull(m)); + if (module(m).mode == FM_SOURCE) { + processModule ( m ); + module(m).tree = NIL; + } else { + processInterfaces ( singleton(snd(grp)) ); + m = findModule(textOf(snd(grp))); + assert(nonNull(m)); + module(m).tree = NIL; + } + break; + case GRP_REC: + for (t = snd(grp); nonNull(t); t=tl(t)) { + m = findModule(textOf(hd(t))); + assert(nonNull(m)); + if (module(m).mode == FM_SOURCE) { + ERRMSG(0) "Source module \"%s\" imports itself recursively", + textToStr(textOf(hd(t))) + EEND; + } + } + processInterfaces ( snd(grp) ); + for (t = snd(grp); nonNull(t); t=tl(t)) { + m = findModule(textOf(hd(t))); + assert(nonNull(m)); + module(m).tree = NIL; + } + break; + default: + internal("tryLoadGroup"); + } } -static Void local project() { /* read list of script names from */ - String s; /* project file */ - if ((s=readFilename()) || currProject) { - if (!s) - s = strCopy(currProject); - else if (readFilename()) { - ERRMSG(0) "Too many project files" - EEND; - } - else - s = strCopy(s); - } - else { - ERRMSG(0) "No project filename specified" - EEND; - } - loadProject(s); - readScripts(1); +static void fallBackToPrelModules ( void ) +{ + Module m; + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) + if (module(m).inUse + && !varIsMember(module(m).text, prelModules)) + nukeModule(m); } -static Void local readScripts(n) /* Reread current list of scripts, */ -Int n; { /* loading everything after and */ - Time timeStamp; /* including the first script which*/ - Long fileSize; /* has been either changed or added*/ - static char name[FILENAME_MAX+1]; - Bool didPrelude; - lastWasObject = FALSE; - ppSmStack("readscripts-begin"); -#if HUGS_FOR_WINDOWS - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif +/* This function catches exceptions in most of the system. + So it's only ok for procedures called from this one + to do EENDs (ie, write error messages). Others should use + EEND_NO_LONGJMP. +*/ +static void achieveTargetModules ( Bool loadingThePrelude ) +{ + volatile List ood; + volatile List modgList; + volatile List t; + volatile Module mod; + volatile Bool ok; + + String path = NULL; + String sExt = NULL; + Bool sAvail; Time sTime; Long sSize; + Bool oiAvail; Time oiTime; Long oSize; Long iSize; + + volatile Time oisTime; + volatile Bool out_of_date; + volatile List ood_new; + volatile List us; + volatile List modgList_new; + volatile List parsedButNotLoaded; + volatile List toChase; + volatile List trans_cl; + volatile List trans_cl_new; + volatile List u; + volatile List mg; + volatile List mg2; + volatile Cell grp; + volatile List badMods; + + setBreakAction ( HugsIgnoreBreak ); + + /* First, examine timestamps to find out which modules are + out of date with respect to the source/interface/object files. + */ + ood = NIL; + modgList = listFromMG(); -#if 0 - for (; n0) /* no new script for prelude */ - startNewScript(scriptName[numScripts]); - if (addScript(scriptName[numScripts],fileSize)) - numScripts++; - else - dropScriptsFrom(numScripts-1); - } -#endif + for (t = modgList; nonNull(t); t=tl(t)) { - interface(RESET); - - for (; n0) - startNewScript(scriptInfo[numScripts].modName); - nextNumScripts = NUM_SCRIPTS; //bogus initialisation - if (addScript(numScripts)) { - numScripts++; - assert(nextNumScripts==NUM_SCRIPTS); - } - else - dropScriptsFrom(numScripts-1); + if (path) { free(path); path = NULL; }; + } + + /* Second, form a simplistic transitive closure of the out-of-date + modules: a module is out of date if it imports an out-of-date + module. + */ + while (1) { + ood_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + for (us = module(mod).uses; nonNull(us); us=tl(us)) + if (varIsMember(textOf(hd(us)),ood)) + break; + if (nonNull(us)) { + if (varIsMember(textOf(hd(t)),prelModules)) + Printf ( "warning: prelude module \"%s\" is out-of-date\n", + textToStr(textOf(hd(t))) ); + else + if (!varIsMember(textOf(hd(t)),ood_new) && + !varIsMember(textOf(hd(t)),ood)) + ood_new = cons(hd(t),ood_new); + } + } + if (isNull(ood_new)) break; + ood = appendOnto(ood_new,ood); + } + + /* Now ood holds the entire set of modules which are out-of-date. + Throw them out of the system, yielding a "reduced system", + in which the remaining modules are in-date. + */ + for (t = ood; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + nukeModule(mod); + } + modgList_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) + if (!varIsMember(textOf(hd(t)),ood)) + modgList_new = cons(hd(t),modgList_new); + modgList = modgList_new; + + /* Update the module group list to reflect the reduced system. + We do this so that if the following parsing phases fail, we can + safely fall back to the reduced system. + */ + mgFromList ( modgList ); + + /* Parse modules/interfaces, collecting parse trees and chasing + imports, starting from the target set. + */ + toChase = dupList(targetModules); + for (t = toChase; nonNull(t); t=tl(t)) { + Cell mode = (!combined) + ? FM_SOURCE + : ( (loadingThePrelude && combined) + ? FM_OBJECT + : FM_EITHER ); + hd(t) = zpair(hd(t), mode); + } + + /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */ + + parsedButNotLoaded = NIL; + + + while (nonNull(toChase)) { + ConId mc = zfst(hd(toChase)); + Cell mode = zsnd(hd(toChase)); + toChase = tl(toChase); + if (varIsMember(textOf(mc),modgList) + || varIsMember(textOf(mc),parsedButNotLoaded)) { + /* either exists fully, or is at least parsed */ + mod = findModule(textOf(mc)); + assert(nonNull(mod)); + if (!compatibleNewMode(mode,module(mod).mode)) { + clearCurrentFile(); + ERRMSG(0) + "module %s: %s required, but %s is more recent", + textToStr(textOf(mc)), modeToString(mode), + modeToString(module(mod).mode) + EEND_NO_LONGJMP; + goto parseException; + } + } else { + + setBreakAction ( HugsLongjmpOnBreak ); + if (setjmp(catch_error)==0) { + /* try this; it may throw an exception */ + mod = parseModuleOrInterface ( mc, mode ); + } else { + /* here's the exception handler, if parsing fails */ + /* A parse error (or similar). Clean up and abort. */ + parseException: + setBreakAction ( HugsIgnoreBreak ); + mod = findModule(textOf(mc)); + if (nonNull(mod)) nukeModule(mod); + for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + if (nonNull(mod)) nukeModule(mod); + } + return; + /* end of the exception handler */ + } + setBreakAction ( HugsIgnoreBreak ); - } else { + parsedButNotLoaded = cons(mc, parsedButNotLoaded); + for (t = module(mod).uses; nonNull(t); t=tl(t)) + toChase = cons( + zpair( hd(t), childMode(mode,module(mod).mode) ), + toChase); + } + } + + modgList = dupOnto(parsedButNotLoaded, modgList); + + /* We successfully parsed all modules reachable from the target + set which were not part of the reduced system. However, there + may be modules in the reduced system which are not reachable from + the target set. We detect these now by building the transitive + closure of the target set, and nuking modules in the reduced + system which are not part of that closure. + */ + trans_cl = dupList(targetModules); + while (1) { + trans_cl_new = NIL; + for (t = trans_cl; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + for (u = module(mod).uses; nonNull(u); u=tl(u)) + if (!varIsMember(textOf(hd(u)),trans_cl) + && !varIsMember(textOf(hd(u)),trans_cl_new) + && !varIsMember(textOf(hd(u)),prelModules)) + trans_cl_new = cons(hd(u),trans_cl_new); + } + if (isNull(trans_cl_new)) break; + trans_cl = appendOnto(trans_cl_new,trans_cl); + } + modgList_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) { + if (varIsMember(textOf(hd(t)),trans_cl)) { + modgList_new = cons(hd(t),modgList_new); + } else { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + nukeModule(mod); + } + } + modgList = modgList_new; + + /* Now, the module symbol tables hold exactly the set of + modules reachable from the target set, and modgList holds + their names. Calculate the scc-ified module graph, + since we need that to guide the next stage, that of + Actually Loading the modules. + + If no errors occur, moduleGraph will reflect the final graph + loaded. If an error occurs loading a group, we nuke + that group, truncate the moduleGraph just prior to that + group, and exit. That leaves the system having successfully + loaded all groups prior to the one which failed. + */ + mgFromList ( modgList ); + + for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) { + grp = hd(mg); - if (scriptInfo[numScripts].objLoaded) { - numScripts++; - } else { - scriptInfo[numScripts].objLoaded = TRUE; - /* new */ - if (numScripts>0) - startNewScript(scriptInfo[numScripts].modName); - /* end */ - nextNumScripts = NUM_SCRIPTS; - if (addScript(numScripts)) { - numScripts++; - assert(nextNumScripts==NUM_SCRIPTS); - } else { - //while (!scriptInfo[numScripts].fromSource && numScripts > 0) - // numScripts--; - //if (scriptInfo[numScripts].fromSource) - // numScripts++; - numScripts = nextNumScripts; - assert(nextNumScripts0) - Printf(", %u garbage collection%s",plural(numGcs)); - Printf(")\n"); -#undef plural - } - FlushStdout(); - garbageCollect(); - } -} + /* -------------------------------------------------------------------------- * Print type of input expression: * ------------------------------------------------------------------------*/ -static Void local showtype() { /* print type of expression (if any)*/ - Cell type; - - setCurrModule(findEvalModule()); - startNewScript(0); /* Enables recovery of storage */ - /* allocated during evaluation */ - parseExp(); - checkExp(); - defaultDefns = evalDefaults; - type = typeCheckExp(FALSE); - printExp(stdout,inputExpr); - Printf(" :: "); - printType(stdout,type); - Putchar('\n'); +static Void showtype ( void ) { /* print type of expression (if any)*/ + + volatile Cell type; + volatile Module evalMod = allocEvalModule(); + volatile Module currMod = currentModule; + setCurrModule(evalMod); + + if (setjmp(catch_error)==0) { + /* try this */ + parseExp(); + checkExp(); + defaultDefns = evalDefaults; + type = typeCheckExp(FALSE); + printExp(stdout,inputExpr); + Printf(" :: "); + printType(stdout,type); + Putchar('\n'); + } else { + /* if an exception happens, we arrive here */ + } + + nukeModule(evalMod); + setCurrModule(currMod); } @@ -1522,8 +1891,6 @@ static Void local browse() { /* browse modules */ String s; Bool all = FALSE; - setCurrModule(findEvalModule()); - startNewScript(0); /* for recovery of storage */ for (; (s=readFilename())!=0; count++) if (strcmp(s,"all") == 0) { all = TRUE; @@ -1531,7 +1898,7 @@ static Void local browse() { /* browse modules */ } else browseit(findModule(findText(s)),s,all); if (count == 0) { - browseit(findEvalModule(),NULL,all); + browseit(currentModule,NULL,all); } } @@ -1617,6 +1984,51 @@ Cell c; { extern Name nameHw; +static Void dumpStg ( void ) +{ + String s; + Int i; +#if 0 + Whats this for? + setCurrModule(findEvalModule()); + startNewScript(0); +#endif + s = readFilename(); + + /* request to locate a symbol by name */ + if (s && (*s == '?')) { + Text t = findText(s+1); + locateSymbolByName(t); + return; + } + + /* request to dump a bit of the heap */ + if (s && (*s == '-' || isdigit(*s))) { + int i = atoi(s); + print(i,100); + printf("\n"); + return; + } + + /* request to dump a symbol table entry */ + if (!s + || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i') + || !isdigit(s[1])) { + fprintf(stderr, ":d -- bad request `%s'\n", s ); + return; + } + i = atoi(s+1); + switch (*s) { + case 't': dumpTycon(i); break; + case 'n': dumpName(i); break; + case 'c': dumpClass(i); break; + case 'i': dumpInst(i); break; + default: fprintf(stderr, ":d -- `%c' not implemented\n", *s ); + } +} + + +#if 0 static Void local dumpStg( void ) { /* print STG stuff */ String s; Text t; @@ -1664,18 +2076,17 @@ static Void local dumpStg( void ) { /* print STG stuff */ } } } +#endif static Void local info() { /* describe objects */ Int count = 0; /* or give menu of commands */ String s; - setCurrModule(findEvalModule()); - startNewScript(0); /* for recovery of storage */ for (; (s=readFilename())!=0; count++) { describe(findText(s)); } if (count == 0) { - whatScripts(); + /* whatScripts(); */ } } @@ -1824,7 +2235,6 @@ Text t; { } else { Printf(""); } -printf("\n");print(name(nm).type,10);printf("\n"); if (isCfun(nm)) { Printf(" -- data constructor"); } else if (isMfun(nm)) { @@ -1884,7 +2294,7 @@ static Void local listNames() { /* list names matching optional pat*/ Int width = getTerminalWidth() - 1; Int count = 0; Int termPos; - Module mod = findEvalModule(); + Module mod = currentModule; if (pat) { /* First gather names to list */ do { @@ -1894,8 +2304,10 @@ static Void local listNames() { /* list names matching optional pat*/ names = addNamesMatching((String)0,names); } if (isNull(names)) { /* Then print them out */ + clearCurrentFile(); ERRMSG(0) "No names selected" - EEND; + EEND_NO_LONGJMP; + return; } for (termPos=0; nonNull(names); names=tl(names)) { String s = objToStr(mod,hd(names)); @@ -1944,57 +2356,70 @@ String moduleName; { * main read-eval-print loop, with error trapping: * ------------------------------------------------------------------------*/ -static jmp_buf catch_error; /* jump buffer for error trapping */ - static Void local interpreter(argc,argv)/* main interpreter loop */ Int argc; String argv[]; { - Int errorNumber = setjmp(catch_error); - if (errorNumber && autoMain) { - fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" ); + List modConIds; /* :: [CONID] */ + Bool prelOK; + String s; + + setBreakAction ( HugsIgnoreBreak ); + modConIds = initialize(argc,argv); /* the initial modules to load */ + setBreakAction ( HugsIgnoreBreak ); + prelOK = loadThePrelude(); + + if (!prelOK) { + if (autoMain) + fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" ); + else + fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" ); exit(1); - } + } - breakOn(TRUE); /* enable break trapping */ - if (numScripts==0) { /* only succeeds on first time, */ - if (errorNumber) /* before prelude has been loaded */ - fatal("Unable to load prelude"); - initialize(argc,argv); - forHelp(); + if (combined) everybody(POSTPREL); + loadActions(modConIds); + + if (autoMain) { + for (; nonNull(modConIds); modConIds=tl(modConIds)) + if (!elemMG(hd(modConIds))) { + fprintf(stderr, + "hugs +Q: compilation failed -- can't run `main'\n" ); + exit(1); + } } + modConIds = NIL; + /* initialize calls startupHaskell, which trashes our signal handlers */ - breakOn(TRUE); + setBreakAction ( HugsIgnoreBreak ); + forHelp(); for (;;) { Command cmd; everybody(RESET); /* reset to sensible initial state */ - dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */ - /* not counting prelude as a script*/ - promptForInput(textToStr(module(findEvalModule()).text)); + promptForInput(textToStr(module(currentModule).text)); cmd = readCommand(cmds, (Char)':', (Char)'!'); -#ifdef WANT_TIMER - updateTimers(); -#endif switch (cmd) { case EDIT : editor(); break; case FIND : find(); break; - case LOAD : clearProject(); - forgetScriptsFrom(1); - load(); - break; - case ALSO : clearProject(); - forgetScriptsFrom(numScripts); - load(); + case LOAD : modConIds = NIL; + while ((s=readFilename())!=0) + modConIds = cons(mkCon(findText(s)),modConIds); + loadActions(modConIds); + modConIds = NIL; break; - case RELOAD : readScripts(1); + case ALSO : modConIds = NIL; + while ((s=readFilename())!=0) + modConIds = cons(mkCon(findText(s)),modConIds); + addActions(modConIds); + modConIds = NIL; break; - case PROJECT: project(); + case RELOAD : refreshActions(NIL,FALSE); break; case SETMODULE : setModule(); @@ -2043,14 +2468,9 @@ String argv[]; { break; case NOCMD : break; } -#ifdef WANT_TIMER - updateTimers(); - Printf("Elapsed time (ms): %ld (user), %ld (system)\n", - millisecs(userElapsed), millisecs(systElapsed)); -#endif + if (autoMain) break; } - breakOn(FALSE); } /* -------------------------------------------------------------------------- @@ -2143,17 +2563,45 @@ static Void local failed() { /* Goal cannot be reached due to */ * Error handling: * ------------------------------------------------------------------------*/ +static Void local stopAnyPrinting() { /* terminate printing of expression,*/ + if (printing) { /* after successful termination or */ + printing = FALSE; /* runtime error (e.g. interrupt) */ + 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"); +#undef plural + } + FlushStdout(); + garbageCollect(); + } +} + +Cell errAssert(l) /* message to use when raising asserts, etc */ +Int l; { + Cell str; + if (currentFile) { + str = mkStr(findText(currentFile)); + } else { + str = mkStr(findText("")); + } + return (ap2(nameTangleMessage,str,mkInt(l))); +} + Void errHead(l) /* print start of error message */ Int l; { failed(); /* failed to reach target ... */ stopAnyPrinting(); FPrintf(errorStream,"ERROR"); - if (scriptFile) { - FPrintf(errorStream," \"%s\"", scriptFile); - setLastEdit(scriptFile,l); + if (currentFile) { + FPrintf(errorStream," \"%s\"", currentFile); + setLastEdit(currentFile,l); if (l) FPrintf(errorStream," (line %d)",l); - scriptFile = 0; + currentFile = NULL; } FPrintf(errorStream,": "); FFlush(errorStream); @@ -2165,6 +2613,11 @@ Void errFail() { /* terminate error message and */ longjmp(catch_error,1); } +Void errFail_no_longjmp() { /* terminate error message but */ + Putc('\n',errorStream); /* don't produce an exception */ + FFlush(errorStream); +} + Void errAbort() { /* altern. form of error handling */ failed(); /* used when suitable error message*/ stopAnyPrinting(); /* has already been printed */ @@ -2173,48 +2626,22 @@ Void errAbort() { /* altern. form of error handling */ Void internal(msg) /* handle internal error */ String msg; { -#if HUGS_FOR_WINDOWS - char buf[300]; - wsprintf(buf,"INTERNAL ERROR: %s",msg); - MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK); -#endif failed(); stopAnyPrinting(); Printf("INTERNAL ERROR: %s\n",msg); FlushStdout(); +exit(9); longjmp(catch_error,1); } Void fatal(msg) /* handle fatal error */ String msg; { -#if HUGS_FOR_WINDOWS - char buf[300]; - wsprintf(buf,"FATAL ERROR: %s",msg); - MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK); -#endif FlushStdout(); Printf("\nFATAL ERROR: %s\n",msg); everybody(EXIT); exit(1); } -sigHandler(breakHandler) { /* respond to break interrupt */ -#if HUGS_FOR_WINDOWS - MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK); -#endif - Hilite(); - Printf("{Interrupted!}\n"); - Lolite(); - breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */ - /* but essential on POSIX (and other?) systems */ - everybody(BREAK); - failed(); - stopAnyPrinting(); - FlushStdout(); - clearerr(stdin); - longjmp(catch_error,1); - sigResume;/*NOTREACHED*/ -} /* -------------------------------------------------------------------------- * Read value from environment variable or registry: @@ -2246,83 +2673,24 @@ String s; { return NULL; } + /* -------------------------------------------------------------------------- * Compiler output * We can redirect compiler output (prompts, error messages, etc) by * tweaking these functions. * ------------------------------------------------------------------------*/ -#if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS - #ifdef HAVE_STDARG_H #include #else #include #endif -/* ----------------------------------------------------------------------- */ - -#define BufferSize 10000 /* size of redirected output buffer */ - -typedef struct _HugsStream { - char buffer[BufferSize]; /* buffer for redirected output */ - Int next; /* next space in buffer */ -} HugsStream; - -static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list)); -static Void local bufferedPutchar Args((HugsStream*, Char)); -static String local bufferClear Args((HugsStream *stream)); - -static Void local vBufferedPrintf(stream, fmt, ap) -HugsStream* stream; -const char* fmt; -va_list ap; { - Int spaceLeft = BufferSize - stream->next; - char* p = &stream->buffer[stream->next]; - Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap); - if (0 <= charsAdded && charsAdded < spaceLeft) - stream->next += charsAdded; -#if 1 /* we can either buffer the first n chars or buffer the last n chars */ - else - stream->next = 0; -#endif -} - -static Void local bufferedPutchar(stream, c) -HugsStream *stream; -Char c; { - if (BufferSize - stream->next >= 2) { - stream->buffer[stream->next++] = c; - stream->buffer[stream->next] = '\0'; - } -} - -static String local bufferClear(stream) -HugsStream *stream; { - if (stream->next == 0) { - return ""; - } else { - stream->next = 0; - return stream->buffer; - } -} - -/* ----------------------------------------------------------------------- */ - -static HugsStream outputStreamH; -/* ADR note: - * We rely on standard C semantics to initialise outputStreamH.next to 0. - */ - Void hugsEnableOutput(f) Bool f; { disableOutput = !f; } -String hugsClearOutputBuffer() { - return bufferClear(&outputStreamH); -} - #ifdef HAVE_STDARG_H Void hugsPrintf(const char *fmt, ...) { va_list ap; /* pointer into argument list */ @@ -2330,7 +2698,6 @@ Void hugsPrintf(const char *fmt, ...) { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -2343,7 +2710,6 @@ va_dcl { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -2354,7 +2720,6 @@ int c; { if (!disableOutput) { putchar(c); } else { - bufferedPutchar(&outputStreamH, c); } } @@ -2378,7 +2743,6 @@ Void hugsFPrintf(FILE *fp, const char* fmt, ...) { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -2392,7 +2756,6 @@ va_dcl { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -2404,11 +2767,9 @@ FILE* fp; { if (!disableOutput) { putc(c,fp); } else { - bufferedPutchar(&outputStreamH, c); } } - -#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */ + /* -------------------------------------------------------------------------- * Send message to each component of system: * ------------------------------------------------------------------------*/ @@ -2429,12 +2790,14 @@ Int what; { /* system to respond as appropriate ... */ typeChecker(what); compiler(what); codegen(what); -} -/* -------------------------------------------------------------------------- - * Hugs for Windows code (WinMain and related functions) - * ------------------------------------------------------------------------*/ + if (what == MARK) { + mark(moduleGraph); + mark(prelModules); + mark(targetModules); + mark(daSccs); + mark(currentModule_failed); + } +} -#if HUGS_FOR_WINDOWS -#include "winhugs.c" -#endif +/*-------------------------------------------------------------------------*/