From 73be95706890e7e8aa344d51592c5b7b02e07216 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 22 Mar 2000 18:14:23 +0000 Subject: [PATCH] [project @ 2000-03-22 18:14:22 by sewardj] Initial commit of major changes to module chasing and storage management: * Total reimplementation of module chasing (see achieveTargetModules in hugs.c). Build, maintain and use module dependency graphs to decide what needs reloading when. The old mechanism with a stack of scripts, etc, is gone forever. All the rest of these points are in support of the module-chasing change: * The result of parsing a module is now a parse tree, rather than a half-baked parse tree and a bunch of side-effects. Hooray! * Redo symbol tables for Names, Tycons, Classes, Instances and Modules. They are now dynamically expandable, doubling in size automatically when full, and use a freelist system to keep track of available slots. * Allow arbitrary modules to be deleted from the system. The main honcho here is nukeModule(). * Not strictly necessary, but ... unify the address space for all compile-time entities. See revised whatIs(). Text is part of the unified address space. This is very convenient for debugging. print() can now print practically anything. Generally simplify storage management as much as possible, and zap the years of elaborate hacks needed to make Hugs work well in 16-bit systems. Added a load of sanity-checking support to storage.[ch]. * We don't support project files any more. They were useful for a while, but no longer seem relevant. * Nuked a large bunch of irrelevant options in rts/options.h. As of this commit, the system can load and chase modules, both in standalone and combined modes. The :l (load), :a (also), :r (refresh), :i (info), :t (show type) and :m (set eval module) commands appear to work. There are also several temporary limitations which will be fixed soon: * Anything to do with external editors, etc, doesn't work. * The downward-closure-of-object-code (if M is object, all modules below M must be too) is not enforced nor checked for. It needs to be. * Module M _must_ reside in M.hs/M.o (sigh). To be fixed. * Error handling is probably flaky, and interrupt handling very likely is. * Error messages don't have line numbers. (A 5-minute fix). * Progress messages are all at sea; needs re-thinking now that the order in which things are done is radically different. * Compile-time GC is temporarily disabled whilst I figure out how to stress-test the GC. * Freed-up symbol table entries are never re-entered on the free lists -- a debugging measure. * :% is given a bad type in combined mode. To be investigated. --- ghc/interpreter/Makefile | 4 +- ghc/interpreter/codegen.c | 59 +- ghc/interpreter/connect.h | 38 +- ghc/interpreter/errors.h | 18 +- ghc/interpreter/hugs.c | 1782 +++++++++++++++++++++++-------------------- ghc/interpreter/input.c | 72 +- ghc/interpreter/interface.c | 107 +-- ghc/interpreter/lift.c | 6 +- ghc/interpreter/link.c | 66 +- ghc/interpreter/machdep.c | 44 +- ghc/interpreter/parser.y | 206 +++-- ghc/interpreter/prelude.h | 71 +- ghc/interpreter/scc.c | 13 +- ghc/interpreter/static.c | 72 +- ghc/interpreter/storage.c | 1513 ++++++++++++++++++------------------ ghc/interpreter/storage.h | 769 +++++++++++-------- ghc/interpreter/subst.c | 19 +- 17 files changed, 2438 insertions(+), 2421 deletions(-) diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile index 42550de..84a7ea1 100644 --- a/ghc/interpreter/Makefile +++ b/ghc/interpreter/Makefile @@ -1,6 +1,6 @@ # --------------------------------------------------------------------------- # -# $Id: Makefile,v 1.27 2000/02/24 14:40:38 sewardj Exp $ # +# $Id: Makefile,v 1.28 2000/03/22 18:14:22 sewardj Exp $ # # --------------------------------------------------------------------------- # TOP = .. @@ -44,7 +44,7 @@ C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \ translate.c codegen.c lift.c free.c stgSubst.c output.c \ hugs.c dynamic.c stg.c sainteger.c object.c interface.c -SRC_CC_OPTS = -g -O -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline +SRC_CC_OPTS = -g -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline GHC_LIBS_NEEDED = $(GHC_RUNTIME_DIR)/libHSrts.a diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index e14af55..375e4af 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.18 $ - * $Date: 2000/03/10 20:03:36 $ + * $Revision: 1.19 $ + * $Date: 2000/03/22 18:14:22 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -88,31 +88,20 @@ char* lookupHugsName( void* closure ) { extern Name nameHw; Name nm; - for( nm=NAMEMIN; nm -# define ctrlbrk(bh) { sigset_t mask; \ +#if HAVE_SIGPROCMASK +#include +#define ctrlbrk(bh) { sigset_t mask; \ signal(SIGINT,bh); \ sigemptyset(&mask); \ sigaddset(&mask, SIGINT); \ sigprocmask(SIG_UNBLOCK, &mask, NULL); \ } -# else +#else # define ctrlbrk(bh) signal(SIGINT,bh) -# endif +#endif + #if SYMANTEC_C extern int time_release; extern int allow_break_count; @@ -592,7 +589,6 @@ extern int allow_break_count; #else # define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); } #endif -#endif /* !HUGS_FOR_WINDOWS */ /*--------------------------------------------------------------------------- @@ -623,10 +619,10 @@ extern char installDir[N_INSTALLDIR]; #if HAVE_UNISTD_H # include # include -#elif !HUGS_FOR_WINDOWS -extern int chdir ( const char* ); #endif +extern int chdir ( const char* ); + #if HAVE_STDLIB_H # include #else @@ -712,8 +708,8 @@ extern Void gcCStack ( Void ); *-------------------------------------------------------------------------*/ extern Cell parseInterface ( String,Long ); -extern ZPair readInterface ( String,Long ); -extern Bool processInterfaces ( Void ); +extern List getInterfaceImports ( Cell ); +extern void processInterfaces ( List ); extern Void getFileSize ( String, Long * ); extern Void ifLinkConstrItbl ( Name n ); extern Void hi_o_namesFromSrcName ( String,String*,String* oName ); @@ -928,11 +924,7 @@ typedef struct { /* Each type variable contains: */ Kind kind; /* kind annotation */ } Tyvar; -#if FIXED_SUBST /* storage for type variables */ -extern Tyvar tyvars[]; -#else extern Tyvar *tyvars; /* storage for type variables */ -#endif extern Int typeOff; /* offset of result type */ extern Type typeIs; /* skeleton of result type */ extern Int typeFree; /* freedom in instantiated type */ diff --git a/ghc/interpreter/errors.h b/ghc/interpreter/errors.h index 512853a..e77f5c1 100644 --- a/ghc/interpreter/errors.h +++ b/ghc/interpreter/errors.h @@ -9,25 +9,20 @@ * included in the distribution. * * $RCSfile: errors.h,v $ - * $Revision: 1.7 $ - * $Date: 2000/03/15 23:27:16 $ + * $Revision: 1.8 $ + * $Date: 2000/03/22 18:14:22 $ * ------------------------------------------------------------------------*/ extern Void internal ( String) HUGS_noreturn; extern Void fatal ( String) HUGS_noreturn; -#if HUGS_FOR_WINDOWS -#define Hilite() WinTextcolor(hWndText,RED); -#define Lolite() WinTextcolor(hWndText,BLACK); -#define errorStream stderr -#else #define Hilite() doNothing() #define Lolite() doNothing() #define errorStream stdout -#endif #define ERRMSG(l) Hilite(); errHead(l); FPrintf(errorStream, #define EEND ); Lolite(); errFail() +#define EEND_NO_LONGJMP ); Lolite(); errFail_no_longjmp() #define ETHEN ); #define ERRTEXT Hilite(); FPrintf(errorStream, #define ERREXPR(e) Hilite(); printExp(errorStream,e); Lolite() @@ -38,9 +33,10 @@ extern Void fatal ( String) HUGS_noreturn; #define ERRKINDS(ks) Hilite(); printKinds(errorStream,ks); Lolite() #define ERRFD(fd) Hilite(); printFD(errorStream,fd); Lolite() -extern Void errHead ( Int ); /* in main.c */ -extern Void errFail ( Void) HUGS_noreturn; -extern Void errAbort ( Void ); +extern Void errHead ( Int ); /* in main.c */ +extern Void errFail ( Void ) HUGS_noreturn; +extern Void errFail_no_longjmp ( Void ); +extern Void errAbort ( Void ); extern Cell errAssert ( Int ); extern sigProto(breakHandler); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 8e3002c..a057b50 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.45 $ - * $Date: 2000/03/20 04:26:23 $ + * $Revision: 1.46 $ + * $Date: 2000/03/22 18:14:22 $ * ------------------------------------------------------------------------*/ #include @@ -41,7 +41,7 @@ Bool multiInstRes = FALSE; * Local function prototypes: * ------------------------------------------------------------------------*/ -static Void local initialize ( Int,String [] ); +static List local initialize ( Int,String [] ); static Void local promptForInput ( String ); static Void local interpreter ( Int,String [] ); static Void local menu ( Void ); @@ -51,14 +51,11 @@ static Void local set ( Void ); static Void local changeDir ( Void ); static Void local load ( Void ); static Void local project ( Void ); -static Void local readScripts ( Int ); -static Void local whatScripts ( 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 Module local findEvalModule ( Void ); static Void local evaluator ( Void ); static Void local stopAnyPrinting ( Void ); static Void local showtype ( Void ); @@ -72,7 +69,7 @@ static Void local listNames ( Void ); static Void local toggleSet ( Char,Bool ); static Void local togglesIn ( Bool ); static Void local optionInfo ( Void ); -#if USE_REGISTRY || HUGS_FOR_WINDOWS +#if USE_REGISTRY static String local optionsToStr ( Void ); #endif static Void local readOptions ( String ); @@ -80,10 +77,6 @@ static Bool local processOption ( String ); static Void local setHeapSize ( String ); static Int local argToInt ( String ); -static Void local loadProject ( String ); -static Void local clearProject ( Void ); -static Bool local addScript ( Int ); -static Void local forgetScriptsFrom ( Script ); static Void local setLastEdit ( String,Int ); static Void local failed ( Void ); static String local strCopy ( String ); @@ -95,9 +88,6 @@ static Void local browse ( Void ); * ------------------------------------------------------------------------*/ #include "machdep.c" -#ifdef WANT_TIMER -#include "timer.c" -#endif /* -------------------------------------------------------------------------- * Local data areas: @@ -117,30 +107,6 @@ static Bool lastWasObject = 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 ( ScriptInfo*,String ); -static Void local addStackEntry ( 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) */ @@ -159,44 +125,6 @@ static Int hpSize = DEFAULTHEAP; /* Desired heap size */ List ifaces_outstanding = NIL; -#if REDIRECT_OUTPUT -static Bool disableOutput = FALSE; /* redirect output to buffer? */ -#endif - -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: @@ -229,15 +157,17 @@ 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); } } @@ -275,112 +205,85 @@ char *argv[]; { * Initialization, interpret command line args and read prelude: * ------------------------------------------------------------------------*/ -static Void local initialize(argc,argv)/* Interpreter initialization */ +static List /*CONID*/ 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 = ""; + Int i; + String proj = 0; + char argv_0_orig[1000]; + List initialModules; + + setLastEdit((String)0,0); + lastEdit = 0; + scriptFile = 0; + +#if SYMANTEC_C + hugsEdit = ""; #else - hugsEdit = strCopy(fromEnv("EDITOR",NULL)); + hugsEdit = strCopy(fromEnv("EDITOR",NULL)); #endif - hugsPath = strCopy(HUGSPATH); - readOptions("-p\"%s> \" -r$$"); + hugsPath = strCopy(HUGSPATH); + readOptions("-p\"%s> \" -r$$"); #if USE_REGISTRY - projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot, + projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot, "HUGSPATH", PATHSEP, "")); - readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options","")); - readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options","")); + readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options","")); + readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options","")); #endif /* USE_REGISTRY */ - readOptions(fromEnv("STGHUGSFLAGS","")); + 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; + argc = prog_argc; + argv = prog_argv; + +# if DEBUG + { + char exe_name[N_INSTALLDIR + 6]; + strcpy(exe_name, installDir); + strcat(exe_name, "hugs"); + DEBUG_LoadSymbols(exe_name); + } +# endif - /* 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. - */ + /* Find out early on if we're in combined mode or not. + everybody(PREPREL) needs to know this. + */ 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 (combined) addStackEntry("PrelHugs"); + everybody(PREPREL); + initialModules = NIL; 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); + return initialModules; } /* -------------------------------------------------------------------------- @@ -474,7 +377,7 @@ ToDo Putchar('\n'); } -#if USE_REGISTRY || HUGS_FOR_WINDOWS +#if USE_REGISTRY #define PUTC(c) \ *next++=(c) @@ -599,14 +502,8 @@ String s; { /* return FALSE if none found. */ case 'h' : setHeapSize(s+1); 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 */ @@ -833,468 +730,788 @@ static Void local changeDir() { /* change directory */ } } + /* -------------------------------------------------------------------------- - * Loading project and script files: + * The new module chaser, loader, etc * ------------------------------------------------------------------------*/ -static Void local loadProject(s) /* Load project file */ -String s; { - clearProject(); - currProject = s; - projInput(currProject); - scriptFile = currProject; - forgetScriptsFrom(N_PRELUDE_SCRIPTS); - while ((s=readFilename())!=0) - addStackEntry(s); - if (namesUpto<=1) { - ERRMSG(0) "Empty project file" - EEND; - } - scriptFile = 0; - projectLoaded = TRUE; -} +List moduleGraph = NIL; +List prelModules = NIL; +List targetModules = NIL; +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 -} +static void ppMG ( void ) +{ + 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"); + } + } +} + -static Void local makeStackEntry ( ScriptInfo* ent, String iname ) +static Bool elemMG ( ConId mod ) { - Bool ok, fromObj; - Bool sAvail, iAvail, oAvail; - Time sTime, iTime, oTime; - Long sSize, iSize, oSize; - String path, sExt; + 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; +} - 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; - } - /* 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; - } - /* 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 ConId selectArbitrarilyFromGroup ( Cell group ) +{ + switch (whatIs(group)) { + case GRP_NONREC: return snd(group); + case GRP_REC: return hd(snd(group)); + default: internal("selectArbitrarilyFromGroup"); + } } +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)); +} -static Void nukeEnding( String s ) +static List /* of CONID */ listFromMG ( 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 gs; + List cs = NIL; + for (gs = moduleGraph; 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("listFromMG"); + } + } + return cs; +} - 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; +/* 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 - found = FALSE; - for (i = 0; i < namesUpto; i++) - if (strcmp(scriptInfo[i].modName,s)==0) - found = TRUE; +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); + adjList = cons(pair(mT,usesT),adjList); + } - if (!found) { - makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) ); - namesUpto++; - } - free(s); -} + /* 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); + } + snd(hd(t)) = adj; + } -/* 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; + adjList = modScc ( adjList ); + adjList = rev(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 HUGS_FOR_WINDOWS /* Set clock cursor while loading */ - allowBreak(); - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif + if (isRec) + moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else + moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph ); + } +} - // setLastEdit(name,0); - strcpy(name, scriptInfo[stacknum].path); - strcat(name, scriptInfo[stacknum].modName); - if (scriptInfo[stacknum].fromSource) - strcat(name, scriptInfo[stacknum].srcExt); else - strcat(name, ".u_hi"); +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; +} - scriptFile = name; - if (scriptInfo[stacknum].fromSource) { - if (lastWasObject) { - didPrelude = processInterfaces(); - if (didPrelude) { - preludeLoaded = TRUE; - everybody(POSTPREL); - } +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; + + startModule(m); + tree = unap(M_MODULE,module(m).tree); + modNm = zfst3(tree); + assert(textOf(modNm)==module(m).text); /* wrong, but ... */ + setExportList(zsnd3(tree)); + topEnts = zthd3(tree); + + 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(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_CLASS: + classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_INST: + instDefn(zfst3(te2),zsnd3(te2),zthd3(te2)); + break; + case M_DEFAULT: + defaultDefn(zfst(te2),zsnd(te2)); + break; + case M_FOREIGN_IM: + foreignImport(zsel15(te2),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + break; + case M_FOREIGN_EX: + foreignExport(zsel15(te2),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + case M_VALUE: + valDefns = cons(te2,valDefns); + break; + default: + internal("processModule"); } - 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; + } + checkDefns(m); + typeCheckDefns(); + compileDefns(); +} - 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 Module parseModuleOrInterface ( ConId mc, + List renewFromSource, + List renewFromObject ) +{ + /* 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 iAvail; Time iTime; Long iSize; + Bool oAvail; Time oTime; Long oSize; + 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, + &iAvail, &iTime, &iSize, + &oAvail, &oTime, &oSize + ); - iface = readInterface(name,len); - imports = zsnd(iface); iface = zfst(iface); + if (!ok) goto cant_find; + if (!sAvail && !(iAvail && oAvail)) goto cant_find; + + /* Find out whether to use source or object. */ + if (varIsMember(mt,renewFromSource)) { + if (!sAvail) goto cant_find; + useSource = TRUE; + } else + if (varIsMember(mt,renewFromObject)) { + if (!(oAvail && iAvail)) goto cant_find; + useSource = FALSE; + } else + if (sAvail && !(iAvail && oAvail)) { + useSource = TRUE; + } else + if (!sAvail && (iAvail && oAvail)) { + useSource = FALSE; + } else { + useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime)); + } - if (nonNull(imports)) chase(imports); - scriptFile = 0; - lastWasObject = TRUE; + if (!combined && !sAvail) goto cant_find; + if (!combined) useSource = TRUE; - iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) ); - ifaces_outstanding = cons(iface_info,ifaces_outstanding); + /* Actually do the parsing. */ + if (useSource) { + 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).fromSrc = TRUE; + module(mod).lastStamp = sTime; - if (needsImports) return FALSE; + } else { + 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).fromSrc = FALSE; + module(mod).lastStamp = whicheverIsLater(oTime,iTime); } - - 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; + if (path) free(path); + return mod; - needsImports = TRUE; - if (scriptInfo[origPos].fromSource) - scriptInfo[origPos].postponed = TRUE; + cant_find: + if (path) free(path); + ERRMSG(0) + "Can't find source or object+interface for module \"%s\"", + textToStr(mt) + EEND; +} - 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; + +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).fromSrc) { + processModule ( m ); + } else { + processInterfaces ( singleton(snd(grp)) ); + } + break; + case GRP_REC: + for (t = snd(grp); nonNull(t); t=tl(t)) { + m = findModule(textOf(hd(t))); + assert(nonNull(m)); + if (module(m).fromSrc) { + ERRMSG(0) "Source module \"%s\" imports itself recursively", + textToStr(textOf(hd(t))) + 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; + } + processInterfaces ( snd(grp) ); + break; + default: + internal("tryLoadGroup"); + } } -static Void local forgetScriptsFrom(scno)/* remove scripts from system */ -Script scno; { - Script i; -#if 0 - for (i=scno; inamesUpto) - numScripts = scno; + +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); } -/* -------------------------------------------------------------------------- - * 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(N_PRELUDE_SCRIPTS); -} +/* 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 ( void ) +{ + volatile List ood; + volatile List modgList; + volatile List renewFromSource; + volatile List renewFromObject; + volatile List t; + volatile Module mod; + volatile Bool ok; + + String path = NULL; + String sExt = NULL; + Bool sAvail; Time sTime; Long sSize; + Bool iAvail; Time iTime; Long iSize; + Bool oAvail; Time oTime; Long oSize; + + volatile Time oisTime; + volatile Time oiTime; + volatile Bool sourceIsLatest; + 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; + + /* First, examine timestamps to find out which modules are + out of date with respect to the source/interface/object files. + */ + ood = NIL; + modgList = listFromMG(); -static Void local project() { /* read list of script names from */ - String s; /* project file */ + renewFromSource = renewFromObject = NIL; - 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(N_PRELUDE_SCRIPTS); -} + for (t = modgList; nonNull(t); t=tl(t)) { -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; + if (varIsMember(textOf(hd(t)),prelModules)) + continue; - lastWasObject = FALSE; - ppSmStack("readscripts-begin"); -#if HUGS_FOR_WINDOWS - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif + mod = findModule(textOf(hd(t))); + if (isNull(mod)) internal("achieveTargetSet(1)"); + + ok = findFilesForModule ( + textToStr(module(mod).text), + &path, + &sExt, + &sAvail, &sTime, &sSize, + &iAvail, &iTime, &iSize, + &oAvail, &oTime, &oSize + ); + if (!combined && !sAvail) ok = FALSE; + if (!ok) { + fallBackToPrelModules(); + ERRMSG(0) + "Can't find source or object+interface for module \"%s\"", + textToStr(module(mod).text) + EEND_NO_LONGJMP; + if (path) free(path); + return; + } + /* findFilesForModule should enforce this */ + if (!(sAvail || (oAvail && iAvail))) + internal("achieveTargetSet(2)"); + + if (!combined) { + oisTime = sTime; + sourceIsLatest = TRUE; + } else { + if (sAvail && !(oAvail && iAvail)) { + oisTime = sTime; + sourceIsLatest = TRUE; + } else + if (!sAvail && (oAvail && iAvail)) { + oisTime = whicheverIsLater(oTime,iTime); + sourceIsLatest = FALSE; + } else + if (sAvail && (oAvail && iAvail)) { + oisTime = whicheverIsLater(oTime,iTime); + if (firstTimeIsLater(sTime,oisTime)) { + oisTime = sTime; + sourceIsLatest = TRUE; + } else { + sourceIsLatest = FALSE; + } + } else { + internal("achieveTargetSet(1a)"); + } + } + + out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp); + if (out_of_date) { + assert(!varIsMember(textOf(hd(t)),ood)); + ood = cons(hd(t),ood); + if (sourceIsLatest) + renewFromSource = cons(hd(t),renewFromSource); else + renewFromObject = cons(hd(t),renewFromObject); + } -#if 0 - for (; n0) /* no new script for prelude */ - startNewScript(scriptName[numScripts]); - if (addScript(scriptName[numScripts],fileSize)) - numScripts++; - else - dropScriptsFrom(numScripts-1); - } -#endif + if (path) { free(path); path = NULL; }; + } - 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); + /* 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 ); - } else { + 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); } @@ -1525,8 +1763,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; @@ -1534,7 +1770,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); } } @@ -1624,8 +1860,11 @@ 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 */ @@ -1715,13 +1954,11 @@ 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(); */ } } @@ -1929,7 +2166,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 { @@ -1940,7 +2177,8 @@ static Void local listNames() { /* list names matching optional pat*/ } if (isNull(names)) { /* Then print them out */ ERRMSG(0) "No names selected" - EEND; + EEND_NO_LONGJMP; + return; } for (termPos=0; nonNull(names); names=tl(names)) { String s = objToStr(mod,hd(names)); @@ -1989,57 +2227,69 @@ 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" ); - exit(1); - } + List modConIds; /* :: [CONID] */ + Bool prelOK; + String s; 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(); + modConIds = initialize(argc,argv); /* the initial modules to load */ + prelOK = loadThePrelude(); + if (combined) everybody(POSTPREL); + + 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); + } + + 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); + 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(N_PRELUDE_SCRIPTS); - 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(N_PRELUDE_SCRIPTS); + 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); break; case SETMODULE : setModule(); @@ -2088,11 +2338,7 @@ 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); @@ -2188,6 +2434,23 @@ 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; { char tmp[100]; @@ -2200,7 +2463,6 @@ Int l; { return (ap2(nameTangleMessage,str,mkInt(l))); } - Void errHead(l) /* print start of error message */ Int l; { failed(); /* failed to reach target ... */ @@ -2223,6 +2485,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 */ @@ -2231,25 +2498,16 @@ 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); @@ -2257,9 +2515,6 @@ String msg; { } sigHandler(breakHandler) { /* respond to break interrupt */ -#if HUGS_FOR_WINDOWS - MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK); -#endif Hilite(); Printf("{Interrupted!}\n"); Lolite(); @@ -2310,163 +2565,6 @@ String s; { * 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 ( HugsStream*, const char*, va_list ); -static Void local bufferedPutchar ( HugsStream*, Char ); -static String local bufferClear ( 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 */ - va_start(ap, fmt); /* make ap point to first arg after fmt */ - if (!disableOutput) { - vprintf(fmt, ap); - } else { - vBufferedPrintf(&outputStreamH, fmt, ap); - } - va_end(ap); /* clean up */ -} -#else -Void hugsPrintf(fmt, va_alist) -const char *fmt; -va_dcl { - va_list ap; /* pointer into argument list */ - va_start(ap); /* make ap point to first arg after fmt */ - if (!disableOutput) { - vprintf(fmt, ap); - } else { - vBufferedPrintf(&outputStreamH, fmt, ap); - } - va_end(ap); /* clean up */ -} -#endif - -Void hugsPutchar(c) -int c; { - if (!disableOutput) { - putchar(c); - } else { - bufferedPutchar(&outputStreamH, c); - } -} - -Void hugsFlushStdout() { - if (!disableOutput) { - fflush(stdout); - } -} - -Void hugsFFlush(fp) -FILE* fp; { - if (!disableOutput) { - fflush(fp); - } -} - -#ifdef HAVE_STDARG_H -Void hugsFPrintf(FILE *fp, const char* fmt, ...) { - va_list ap; - va_start(ap, fmt); - if (!disableOutput) { - vfprintf(fp, fmt, ap); - } else { - vBufferedPrintf(&outputStreamH, fmt, ap); - } - va_end(ap); -} -#else -Void hugsFPrintf(FILE *fp, const char* fmt, va_list) -FILE* fp; -const char* fmt; -va_dcl { - va_list ap; - va_start(ap); - if (!disableOutput) { - vfprintf(fp, fmt, ap); - } else { - vBufferedPrintf(&outputStreamH, fmt, ap); - } - va_end(ap); -} -#endif - -Void hugsPutc(c, fp) -int c; -FILE* fp; { - if (!disableOutput) { - putc(c,fp); - } else { - bufferedPutchar(&outputStreamH, c); - } -} - -#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */ /* -------------------------------------------------------------------------- * Send message to each component of system: * ------------------------------------------------------------------------*/ @@ -2489,10 +2587,4 @@ Int what; { /* system to respond as appropriate ... */ codegen(what); } -/* -------------------------------------------------------------------------- - * Hugs for Windows code (WinMain and related functions) - * ------------------------------------------------------------------------*/ - -#if HUGS_FOR_WINDOWS -#include "winhugs.c" -#endif +/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index cb744af..6dba435 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: input.c,v $ - * $Revision: 1.21 $ - * $Date: 2000/03/13 11:37:16 $ + * $Revision: 1.22 $ + * $Date: 2000/03/22 18:14:22 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -27,7 +27,7 @@ #include #endif -#if IS_WIN32 || HUGS_FOR_WINDOWS +#if IS_WIN32 #undef IN #endif @@ -567,7 +567,7 @@ static Void local skip() { /* move forward one char in input */ c1 = EOF; else { c1 = nextConsoleChar(); -#if IS_WIN32 && !HUGS_FOR_WINDOWS +#if IS_WIN32 Sleep(0); #endif /* On Win32, hitting ctrl-C causes the next getchar to @@ -1263,7 +1263,7 @@ String readLine() { /* Read command line from input */ * - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{' * is inserted with the column number of the first token after the * WHERE/LET/OF keyword. - * - When a soft indentation is uppermost on the indetation stack with + * - When a soft indentation is uppermost on the indentation stack with * column col' we insert: * `}' in front of token with column #endif -#if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS +#if defined HAVE_CONIO_H # include #endif #ifdef HAVE_IO_H @@ -58,16 +58,6 @@ # include #endif -#if HUGS_FOR_WINDOWS -#include -#include - -extern HCURSOR HandCursor; /* Forward references to cursors */ -extern HCURSOR GarbageCursor; -extern HCURSOR SaveCursor; -static void local DrawStatusLine ( HWND ); -#endif - #if DOS #include extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */ @@ -133,17 +123,7 @@ static String local readRegChildStrings ( HKEY, String, String, Char, String ); * Find information about a file: * ------------------------------------------------------------------------*/ -#if RISCOS -typedef struct { unsigned hi, lo; } Time; -#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo) -#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo -error timeEarlier not defined -#else -typedef time_t Time; -#define timeChanged(now,thn) (now!=thn) -#define timeSet(var,tm) var = tm -#define timeEarlier(earlier,now) (earlier < now) -#endif +#include "machdep_time.h" static Bool local readable ( String ); static Void local getFileInfo ( String, Time *, Long * ); @@ -770,7 +750,7 @@ Bool findFilesForModule ( } -/* If the primaryObjectName for is (eg) +/* If the primaryObjectName is (eg) /foo/bar/PrelSwamp.o and the extraFileName is (eg) swampy_cbits @@ -850,9 +830,6 @@ String sub; { Bool gcMessages = FALSE; /* TRUE => print GC messages */ Void gcStarted() { /* Notify garbage collector start */ -#if HUGS_FOR_WINDOWS - SaveCursor = SetCursor(GarbageCursor); -#endif if (gcMessages) { Printf("{{Gc"); FlushStdout(); @@ -872,9 +849,6 @@ Int recovered; { Printf("%d}}",recovered); FlushStdout(); } -#if HUGS_FOR_WINDOWS - SetCursor(SaveCursor); -#endif } Cell *CStackBase; /* Retain start of C control stack */ @@ -1127,7 +1101,7 @@ Int readTerminalChar() { /* read character from terminal */ if (terminalEchoReqd) { return getchar(); } else { -#if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__ +#if IS_WIN32 && !__BORLANDC__ /* When reading a character from the console/terminal, we want * to operate in 'raw' mode (to use old UNIX tty parlance) and have * it return when a character is available and _not_ wait until @@ -1585,12 +1559,6 @@ Int what; { /* initialisation etc.. */ case RESET : case BREAK : case EXIT : normalTerminal(); -#if HUGS_FOR_WINDOWS - if (what==EXIT) - DestroyWindow(hWndMain); - else - SetCursor(LoadCursor(NULL,IDC_ARROW)); -#endif break; } } diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index f44848d..a681b52 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,15 +12,14 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.25 $ - * $Date: 2000/03/13 11:37:16 $ + * $Revision: 1.26 $ + * $Date: 2000/03/22 18:14:22 $ * ------------------------------------------------------------------------*/ %{ #ifndef lint #define lint #endif -#define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t)) #define fixdecl(l,ops,a,p) ap(FIXDECL,\ triple(l,ops,mkInt(mkSyntax(a,intOf(p))))) @@ -28,8 +27,6 @@ #define only(t) ap(ONLY,t) #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e) #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t) -#define exportSelf() singleton(ap(MODULEENT, \ - mkCon(module(currentModule).text))) #define yyerror(s) /* errors handled elsewhere */ #define YYSTYPE Cell @@ -73,6 +70,8 @@ static Void local noIP ( String ); #define gc5(e) gcShadow(5,e) #define gc6(e) gcShadow(6,e) #define gc7(e) gcShadow(7,e) +#define gc8(e) gcShadow(8,e) +#define gc9(e) gcShadow(9,e) %} @@ -103,11 +102,11 @@ static Void local noIP ( String ); %% /*- Top level script/module structure -------------------------------------*/ -start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} - | CONTEXT context {inputContext = $2; sp-=1;} - | SCRIPT topModule {valDefns = $2; sp-=1;} - | INTERFACE iface {sp-=1;} - | error {syntaxError("input");} +start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} + | CONTEXT context {inputContext = $2; sp-=1;} + | SCRIPT topModule {drop(); push($2);} + | INTERFACE iface {sp-=1;} + | error {syntaxError("input");} ; @@ -132,8 +131,8 @@ ifTopDecls: {$$=gc0(NIL);} ; ifTopDecl - : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList - {$$=gc6(ap(I_IMPORT,zpair($2,$6))); } + : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList + {$$=gc7(ap(I_IMPORT,zpair($2,$7))); } | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));} @@ -182,6 +181,8 @@ ifTopDecl /*- Top-level misc interface stuff ------------------------*/ ifOrphans : '!' {$$=gc1(NIL);} | {$$=gc0(NIL);} +ifIsBoot : '@' {$$=gc1(NIL);} + | {$$=gc0(NIL);} ; ifOptCOCO : COCO {$$=gc1(NIL);} | {$$=gc0(NIL);} @@ -422,57 +423,40 @@ ifVersionList /*- Haskell module header/import parsing: ----------------------------------- - * Syntax for Haskell modules (module headers and imports) is parsed but - * most of it is ignored. However, module names in import declarations - * are used, of course, if import chasing is turned on. + * Module chasing is now totally different from Classic Hugs98. We parse + * the entire syntax tree. Subsequent passes over the tree collect and + * chase imports; we no longer attempt to do so whilst parsing. *-------------------------------------------------------------------------*/ /* In Haskell 1.2, the default module header was "module Main where" * In 1.3, this changed to "module Main(main) where". * We use the 1.2 header because it breaks much less pre-module code. + * STG Hugs, 15 March 00: disallow default headers (pro tem). */ -topModule : startMain begin modBody end { - setExportList(singleton( - ap(MODULEENT, - mkCon(module(currentModule).text) - ))); - $$ = gc3($3); - } - | TMODULE modname expspec WHERE '{' modBody end - {setExportList($3); $$ = gc7($6);} +topModule : TMODULE modname expspec WHERE '{' modBody end + {$$=gc7(ap(M_MODULE, + ztriple($2,$3,$6)));} + | TMODULE modname WHERE '{' modBody end + {$$=gc6(ap(M_MODULE, + ztriple( + $2, + singleton(ap(MODULEENT,$2)), + $5)));} | TMODULE error {syntaxError("module definition");} ; -/* To implement the Haskell module system, we have to keep track of the - * current module. We rely on the use of LALR parsing to ensure that this - * side effect happens before any declarations within the module. - */ -startMain : /* empty */ {startModule(conMain); - $$ = gc0(NIL);} - ; -modname : CONID {startModule($1); $$ = gc1(NIL);} - ; -modid : CONID {$$ = $1;} - | STRINGLIT { extern String scriptFile; - String modName - = findPathname(scriptFile, - textToStr(textOf($1))); - if (modName) { - /* fillin pathname if known */ - $$ = mkStr(findText(modName)); - } else { - $$ = $1; - } - } + +modname : CONID {$$ = gc1($1);} + ; +modid : CONID {$$ = gc1($1);} ; -modBody : topDecls {$$ = $1;} - | impDecls chase {$$ = gc2(NIL);} - | impDecls ';' chase topDecls {$$ = gc4($4);} +modBody : topDecls {$$ = gc1($1);} + | impDecls {$$ = gc1($1);} + | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));} ; /*- Exports: --------------------------------------------------------------*/ -expspec : /* empty */ {$$ = gc0(exportSelf());} - | '(' ')' {$$ = gc2(NIL);} +expspec : '(' ')' {$$ = gc2(NIL);} | '(' exports ')' {$$ = gc3($2);} | '(' exports ',' ')' {$$ = gc4($2);} ; @@ -502,36 +486,32 @@ qname : qvar {$$ = $1;} /*- Import declarations: --------------------------------------------------*/ -impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);} - | impDecl {imps = singleton($1); $$=gc1(NIL);} - ; -chase : /* empty */ {if (chase(imps)) { - clearStack(); - onto(imps); - done(); - closeAnyInput(); - return 0; - } - $$ = gc0(NIL); - } +impDecls : impDecls ';' impDecl {$$ = gc3(appendOnto($3,$1));} + | impDecl {$$ = gc1($1);} ; + /* Note that qualified import ignores the import list. */ -impDecl : IMPORT modid impspec {addQualImport($2,$2); - addUnqualImport($2,$3); - $$ = gc3($2);} +impDecl : IMPORT modid impspec {$$=gc3(doubleton( + ap(M_IMPORT_Q,zpair($2,$2)), + ap(M_IMPORT_UNQ,zpair($2,$3)) + ));} | IMPORT modid ASMOD modid impspec - {addQualImport($2,$4); - addUnqualImport($2,$5); - $$ = gc5($2);} + {$$=gc5(doubleton( + ap(M_IMPORT_Q,zpair($2,$4)), + ap(M_IMPORT_UNQ,zpair($2,$5)) + ));} | IMPORT QUALIFIED modid ASMOD modid impspec - {addQualImport($3,$5); - $$ = gc6($3);} + {$$=gc6(singleton( + ap(M_IMPORT_Q,zpair($3,$5)) + ));} | IMPORT QUALIFIED modid impspec - {addQualImport($3,$3); - $$ = gc4($3);} + {$$=gc4(singleton( + ap(M_IMPORT_Q,zpair($3,$3)) + ));} | IMPORT PRIVILEGED modid '(' imports ')' - {addUnqualImport($3,ap(STAR,$5)); - $$ = gc6($3);} + {$$=gc6(singleton( + ap(M_IMPORT_UNQ, + zpair($3,ap(STAR,$5)))));} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(DOTDOT);} @@ -565,44 +545,50 @@ name : var {$$ = $1;} /*- Top-level declarations: -----------------------------------------------*/ -topDecls : /* empty */ {$$ = gc0(NIL);} - | ';' {$$ = gc1(NIL);} - | topDecls1 {$$ = $1;} - | topDecls1 ';' {$$ = gc2($1);} - ; -topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);} - | topDecls1 ';' decl {$$ = gc3(cons($3,$1));} - | topDecl {$$ = gc0(NIL);} - | decl {$$ = gc1(cons($1,NIL));} - ; +topDecls : /* empty */ {$$=gc0(NIL);} + | topDecl ';' topDecls {$$=gc3(cons($1,$3));} + | decl ';' topDecls {$$=gc3(cons(ap(M_VALUE,$1),$3));} + | topDecl {$$=gc1(cons($1,NIL));} + | decl {$$=gc1(cons(ap(M_VALUE,$1),NIL));} + ; /*- Type declarations: ----------------------------------------------------*/ -topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);} +topDecl : TYPE tyLhs '=' type {$$=gc4(ap(M_TYCON, + z4ble($3,$2,$4, + SYNONYM)));} | TYPE tyLhs '=' type IN invars - {defTycon(6,$3,$2, - ap($4,$6),RESTRICTSYN);} + {$$=gc6(ap(M_TYCON, + z4ble($3,$2,ap($4,$6), + RESTRICTSYN)));} | TYPE error {syntaxError("type definition");} | DATA btype2 '=' constrs deriving - {defTycon(5,$3,checkTyLhs($2), - ap(rev($4),$5),DATATYPE);} + {$$=gc5(ap(M_TYCON, + z4ble($3,checkTyLhs($2), + ap(rev($4),$5), + DATATYPE)));} | DATA context IMPLIES tyLhs '=' constrs deriving - {defTycon(7,$5,$4, - ap(qualify($2,rev($6)), - $7),DATATYPE);} - | DATA btype2 {defTycon(2,$1,checkTyLhs($2), - ap(NIL,NIL),DATATYPE);} - | DATA context IMPLIES tyLhs {defTycon(4,$1,$4, - ap(qualify($2,NIL), - NIL),DATATYPE);} + {$$=gc7(ap(M_TYCON, + z4ble($5,$4, + ap(qualify($2,rev($6)),$7), + DATATYPE)));} + | DATA btype2 {$$=gc2(ap(M_TYCON, + z4ble($1,checkTyLhs($2), + ap(NIL,NIL),DATATYPE)));} + | DATA context IMPLIES tyLhs {$$=gc4(ap(M_TYCON, + z4ble($1,$4, + ap(qualify($2,NIL),NIL), + DATATYPE)));} | DATA error {syntaxError("data definition");} | TNEWTYPE btype2 '=' nconstr deriving - {defTycon(5,$3,checkTyLhs($2), - ap($4,$5),NEWTYPE);} + {$$=gc5(ap(M_TYCON, + z4ble($3,checkTyLhs($2), + ap($4,$5),NEWTYPE)));} | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving - {defTycon(7,$5,$4, - ap(qualify($2,$6), - $7),NEWTYPE);} + {$$=gc7(ap(M_TYCON, + z4ble($5,$4, + ap(qualify($2,$6),$7), + NEWTYPE)));} | TNEWTYPE error {syntaxError("newtype definition");} ; tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));} @@ -674,11 +660,11 @@ derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));} /*- Processing definitions of primitives ----------------------------------*/ topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type - {foreignImport($1,$3,NIL,$6,$8); sp-=8;} + {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));} | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type - {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;} + {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));} | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type - {foreignExport($1,$3,$4,$5,$7); sp-=7;} + {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));} ; callconv : CCALL {$$ = gc1(textCcall);} @@ -696,9 +682,9 @@ unsafe_flag: /* empty */ {$$ = gc0(NIL);} /*- Class declarations: ---------------------------------------------------*/ -topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;} - | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;} - | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;} +topDecl : TCLASS crule fds wherePart {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));} + | TINSTANCE irule wherePart {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));} + | DEFAULT '(' dtypes ')' {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));} | TCLASS error {syntaxError("class declaration");} | TINSTANCE error {syntaxError("instance declaration");} | DEFAULT error {syntaxError("default declaration");} @@ -1279,10 +1265,6 @@ varid1 : VARID {$$ = gc1($1);} /*- Tricks to force insertion of leading and closing braces ---------------*/ -begin : error {yyerrok; - if (offsideON) goOffside(startColumn);} - ; - /* deal with trailing semicolon */ end : '}' {$$ = $1;} | error {yyerrok; if (offsideON && canUnOffside()) { diff --git a/ghc/interpreter/prelude.h b/ghc/interpreter/prelude.h index 50264c1..787e1ae 100644 --- a/ghc/interpreter/prelude.h +++ b/ghc/interpreter/prelude.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: prelude.h,v $ - * $Revision: 1.10 $ - * $Date: 2000/03/13 14:10:24 $ + * $Revision: 1.11 $ + * $Date: 2000/03/22 18:14:23 $ * ------------------------------------------------------------------------*/ #define NON_POSIX_SOURCE @@ -73,35 +73,6 @@ #include /* Misc. Windows hackery */ #endif -#if HUGS_FOR_WINDOWS - -#if __MSDOS__ -# define INT int -# define UNSIGNED unsigned -# define CHAR char -# define TCHAR char -# define UCHAR UNSIGNED CHAR -# define ULONG unsigned long -# define APIENTRY PASCAL -# define HUGE huge -# define LPOFNHOOKPROC FARPROC -# define CMDdata(w,l) (HIWORD(l)) /* decoding WM_COMMAND message */ -# define CMDitem(w,l) (w) -# define CMDhwnd(w,l) ((HWND)(LOWORD(l))) -#else -# define HUGE -# define CMDdata(w,l) (HIWORD(w)) /* decoding WM_COMMAND message */ -# define CMDitem(w,l) (LOWORD(w)) -# define CMDhwnd(w,l) ((HWND)(l)) -#endif - -#include "win-menu.h" -extern char *appName; -extern HWND hWndText; /* text output window handle */ -extern HWND hWndMain; /* main window handle */ -#include "win-text.h" -#endif - /*--------------------------------------------------------------------------- * Macros used in declarations: @@ -265,14 +236,6 @@ typedef shl_t ObjectFile; #endif #endif -#if DYN_TABLES /* Tables may be alloc'd at runtime*/ -#define DECTABLE(tab) far *tab /* macros for declaration & defn */ -#define DEFTABLE(tab,sz) far *tab = 0 -#else /* or at compile-time: */ -#define DECTABLE(tab) tab[] -#define DEFTABLE(tab,sz) tab[sz] -#endif - /*--------------------------------------------------------------------------- * Printf-related operations: *-------------------------------------------------------------------------*/ @@ -284,11 +247,11 @@ typedef shl_t ObjectFile; #endif #if !defined(HAVE_SNPRINTF) -extern int snprintf ( char*, int, const char*, ... ); +extern int snprintf ( char*, int, const char*, ... ); #endif #if !defined(HAVE_VSNPRINTF) -extern int vsnprintf ( char*, int, const char*, va_list ); +extern int vsnprintf ( char*, int, const char*, va_list ); #endif /*--------------------------------------------------------------------------- @@ -296,30 +259,6 @@ extern int vsnprintf ( char*, int, const char*, va_list ); * Tweaking this lets us redirect prompts, error messages, etc - but has no * effect on output of Haskell programs (which should use hPutStr and friends). *-------------------------------------------------------------------------*/ - -#if REDIRECT_OUTPUT - -extern Void hugsPrintf ( const char *, ... ); -extern Void hugsPutchar ( int ); -extern Void hugsFlushStdout ( Void ); -extern Void hugsEnableOutput ( Bool ); -extern String hugsClearOutputBuffer ( Void ); - -extern Void hugsFFlush ( FILE* ); -extern Void hugsFPrintf ( FILE*, const char*, ... ); -extern Void hugsPutc ( int, FILE* ); - -#define Printf hugsPrintf -#define Putchar hugsPutchar -#define FlushStdout hugsFlushStdout -#define EnableOutput hugsEnableOutput -#define ClearOutputBuffer hugsClearOutputBuffer - -#define FFlush hugsFFlush -#define FPrintf hugsFPrintf -#define Putc hugsPutc - -#else #define Printf printf #define Putchar putchar @@ -331,6 +270,4 @@ extern Void hugsPutc ( int, FILE* ); #define FPrintf fprintf #define Putc putc -#endif - /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/scc.c b/ghc/interpreter/scc.c index 837fd17..96d19f8 100644 --- a/ghc/interpreter/scc.c +++ b/ghc/interpreter/scc.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: scc.c,v $ - * $Revision: 1.6 $ - * $Date: 2000/03/13 11:37:16 $ + * $Revision: 1.7 $ + * $Date: 2000/03/22 18:14:23 $ * ------------------------------------------------------------------------*/ #ifndef SCC_C @@ -70,8 +70,8 @@ static Int local LOWLINK( Cell v ) /* calculate `lowlink' of v */ } #ifdef SCC -static List local SCC(bs) /* sort list with added dependency */ -List bs; { /* info into SCCs */ +static List local SCC ( List bs ) /* sort list with added dependency */ +{ /* info into SCCs */ List tmp = NIL; clearStack(); daSccs = NIL; /* clear current list of SCCs */ @@ -86,8 +86,9 @@ List bs; { /* info into SCCs */ #endif #ifdef SCC2 /* Two argument version */ -static List local SCC2(bs,cs) /* sort lists with added dependency*/ -List bs, cs; { /* info into SCCs */ +static List local SCC2 ( List bs, + List cs ) /* sort lists with added dependency*/ +{ /* info into SCCs */ List tmp = NIL; clearStack(); daSccs = NIL; /* clear current list of SCCs */ diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 5c80d98..25896a0 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.30 $ - * $Date: 2000/03/13 11:37:16 $ + * $Revision: 1.31 $ + * $Date: 2000/03/22 18:14:23 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -39,7 +39,7 @@ static Void local importEntity ( Module,Cell ); static Void local importName ( Module,Name ); static Void local importTycon ( Module,Tycon ); static Void local importClass ( Module,Class ); -static List local checkExports ( List ); +static List local checkExports ( List, Module ); static Void local checkTyconDefn ( Tycon ); static Void local depConstrs ( Tycon,List,Cell ); @@ -255,24 +255,9 @@ Kind extKind; /* Kind of extension, *->row->row */ * Static analysis of modules: * ------------------------------------------------------------------------*/ -#if HSCRIPT -String reloadModule; -#endif - -Void startModule(nm) /* switch to a new module */ -Cell nm; { - Module m; - if (!isCon(nm)) internal("startModule"); - if (isNull(m = findModule(textOf(nm)))) - m = newModule(textOf(nm)); - else if (!isPreludeScript()) { - /* You're allowed to break the rules in the Prelude! */ -#if HSCRIPT - reloadModule = textToStr(textOf(nm)); -#endif - ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm)) - EEND; - } +Void startModule ( Module m ) /* switch to a new module */ +{ + if (isNull(m)) internal("startModule"); setCurrModule(m); } @@ -381,10 +366,11 @@ Cell entity; { /* Entry from import list */ case NEWTYPE: case DATATYPE: if (DOTDOT == snd(entity)) { - imports=dupOnto(tycon(f).defn,imports); + imports = dupOnto(tycon(f).defn,imports); } else { - imports=checkSubentities(imports,snd(entity),tycon(f).defn, - "constructor of type",t); + imports = checkSubentities( + imports,snd(entity),tycon(f).defn, + "constructor of type",t); } break; default:; @@ -399,8 +385,9 @@ Cell entity; { /* Entry from import list */ if (DOTDOT == snd(entity)) { return dupOnto(cclass(f).members,imports); } else { - return checkSubentities(imports,snd(entity),cclass(f).members, - "member of class",t); + return checkSubentities( + imports,snd(entity),cclass(f).members, + "member of class",t); } } } @@ -476,11 +463,6 @@ Pair importSpec; { List imports = NIL; /* entities we want to import */ List hidden = NIL; /* entities we want to hide */ - if (moduleThisScript(m)) { - ERRMSG(0) "Module \"%s\" recursively imports itself", - textToStr(module(m).text) - EEND; - } if (isPair(impList) && HIDDEN == fst(impList)) { /* Somewhat inefficient - but obviously correct: * imports = importsOf("module Foo") `setDifference` hidden; @@ -526,7 +508,8 @@ Module source; Name n; { Name clash = addName(n); if (nonNull(clash) && clash!=n) { - ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"", + ERRMSG(0) "Entity \"%s\" imported from module \"%s\"" + " already defined in module \"%s\"", textToStr(name(n).text), textToStr(module(source).text), textToStr(module(name(clash).mod).text) @@ -707,9 +690,9 @@ Cell e; { return exports; /* NOTUSED */ } -static List local checkExports(exports) -List exports; { - Module m = lastModule(); +static List local checkExports ( List exports, Module thisModule ) +{ + Module m = thisModule; Text mt = module(m).text; List es = NIL; @@ -1887,7 +1870,7 @@ Type type; { } if (nonNull(tvs)) { - if (length(tvs)>=NUM_OFFSETS) { + if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) { ERRMSG(line) "Too many type variables in %s\n", where EEND; } else { @@ -3170,7 +3153,7 @@ Int beta; { return copyAdj(tyv->bound,tyv->offs,beta); } vn -= beta; - if (vn<0 || vn>=NUM_OFFSETS) { + if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) { internal("copyAdj"); } return mkOffset(vn); @@ -4734,9 +4717,12 @@ Cell e; { EEND; } +#if 0 + what is this for?? if (!moduleThisScript(name(n).mod)) { return n; } +#endif /* Later phases of the system cannot cope if we resolve references * to unprocessed objects too early. This is the main reason that * we cannot cope with recursive modules at the moment. @@ -5037,8 +5023,8 @@ Void checkContext(void) { /* Top level static check on Expr */ } #endif -Void checkDefns() { /* Top level static analysis */ - Module thisModule = lastModule(); +Void checkDefns ( Module thisModule ) { /* Top level static analysis */ + staticAnalysis(RESET); setCurrModule(thisModule); @@ -5055,8 +5041,9 @@ Void checkDefns() { /* Top level static analysis */ /* Every module (including the Prelude) implicitly contains * "import qualified Prelude" */ - module(thisModule).qualImports=cons(pair(mkCon(textPrelude),modulePrelude), - module(thisModule).qualImports); + module(thisModule).qualImports + =cons(pair(mkCon(textPrelude),modulePrelude), + module(thisModule).qualImports); } mapProc(checkImportList, unqualImports); @@ -5105,7 +5092,8 @@ Void checkDefns() { /* Top level static analysis */ /* export list. Note that this has to happen before dependency */ /* analysis so that references to Prelude.foo will be resolved */ /* when compiling the prelude. */ - module(thisModule).exports = checkExports(module(thisModule).exports); + module(thisModule).exports + = checkExports ( module(thisModule).exports, thisModule ); mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 6bb2306..67cb4c5 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.51 $ - * $Date: 2000/03/13 11:37:17 $ + * $Revision: 1.52 $ + * $Date: 2000/03/22 18:14:23 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -26,20 +26,20 @@ * local function prototypes: * ------------------------------------------------------------------------*/ -static Int local hash ( String ); -static Int local saveText ( Text ); +static Int local hash ( String ); +static Int local saveText ( Text ); static Module local findQualifier ( Text ); -static Void local hashTycon ( Tycon ); -static List local insertTycon ( Tycon,List ); -static Void local hashName ( Name ); -static List local insertName ( Name,List ); -static Void local patternError ( String ); -static Bool local stringMatch ( String,String ); -static Bool local typeInvolves ( Type,Type ); -static Cell local markCell ( Cell ); -static Void local markSnd ( Cell ); -static Cell local lowLevelLastIn ( Cell ); -static Cell local lowLevelLastOut ( Cell ); +static Void local hashTycon ( Tycon ); +static List local insertTycon ( Tycon,List ); +static Void local hashName ( Name ); +static List local insertName ( Name,List ); +static Void local patternError ( String ); +static Bool local stringMatch ( String,String ); +static Bool local typeInvolves ( Type,Type ); +static Cell local markCell ( Cell ); +static Void local markSnd ( Cell ); +static Cell local lowLevelLastIn ( Cell ); +static Cell local lowLevelLastOut ( Cell ); /* -------------------------------------------------------------------------- @@ -71,23 +71,29 @@ static Cell local lowLevelLastOut ( Cell ); #define TEXTHSZ 512 /* Size of Text hash table */ #define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */ static Text textHw; /* Next unused position */ -static Text savedText = NUM_TEXT; /* Start of saved portion of text */ +static Text savedText = TEXT_SIZE; /* Start of saved portion of text */ static Text nextNewText; /* Next new text value */ static Text nextNewDText; /* Next new dict text value */ -static char DEFTABLE(text,NUM_TEXT);/* Storage of character strings */ +static char text[TEXT_SIZE]; /* Storage of character strings */ static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */ String textToStr(t) /* find string corresp to given Text*/ Text t; { static char newVar[16]; - if (0<=t && t= INVAR_BASE_ADDR+INVAR_MAX_AVAIL) + internal("inventText: too many invented variables"); + return nextNewText++; } Text inventDictText() { /* return new unused dictvar name */ - return nextNewDText--; + if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL) + internal("inventDictText: too many invented variables"); + return nextNewDText++; } Bool inventedText(t) /* Signal TRUE if text has been */ Text t; { /* generated internally */ - return (t<0 || t>=NUM_TEXT); + return isInventedVar(t) || isInventedDictVar(t); } #define MAX_FIXLIT 100 @@ -173,13 +183,13 @@ String s; { int hashno = 0; Text textPos = textHash[h][hashno]; -#define TryMatch { Text originalTextPos = textPos; \ +# define TryMatch { Text originalTextPos = textPos; \ String t; \ for (t=s; *t==text[textPos]; textPos++,t++) \ if (*t=='\0') \ - return originalTextPos; \ + return originalTextPos+TEXT_BASE_ADDR; \ } -#define Skip while (text[textPos++]) ; +# define Skip while (text[textPos++]) ; while (textPos!=NOTEXT) { TryMatch @@ -211,14 +221,13 @@ String s; { textHash[h][hashno+1] = NOTEXT; } - return textPos; + return textPos+TEXT_BASE_ADDR; } static Int local saveText(t) /* Save text value in buffer */ Text t; { /* at top of text table */ String s = textToStr(t); Int l = strlen(s); - if (textHw + l + 1 > savedText) { ERRMSG(0) "Character string storage space exhausted" EEND; @@ -404,18 +413,19 @@ Text enZcodeThenFindText ( String s ) Text textOf ( Cell c ) { + Int wot = whatIs(c); Bool ok = - (whatIs(c)==VARIDCELL - || whatIs(c)==CONIDCELL - || whatIs(c)==VAROPCELL - || whatIs(c)==CONOPCELL - || whatIs(c)==STRCELL - || whatIs(c)==DICTVAR - || whatIs(c)==IPCELL - || whatIs(c)==IPVAR + (wot==VARIDCELL + || wot==CONIDCELL + || wot==VAROPCELL + || wot==CONOPCELL + || wot==STRCELL + || wot==DICTVAR + || wot==IPCELL + || wot==IPVAR ); if (!ok) { - fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) ); + fprintf(stderr, "\ntextOf: bad tag %d\n",wot ); internal("textOf: bad tag"); } return snd(c); @@ -452,6 +462,146 @@ Text t; { } #endif + +/* -------------------------------------------------------------------------- + * Expandable symbol tables. A template, which is instantiated for the name, + * tycon, class, instance and module tables. Also, potentially, TREX Exts. + * ------------------------------------------------------------------------*/ + +#define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name, \ + proc_name,free_proc_name, \ + free_list,tab_name,tab_size,err_msg, \ + TAB_INIT_SIZE,TAB_MAX_SIZE, \ + TAB_BASE_ADDR) \ + \ + struct struct_name* tab_name = NULL; \ + int tab_size = 0; \ + static type_name free_list = TAB_BASE_ADDR-1; \ + \ + void free_proc_name ( type_name n ) \ + { \ + assert(TAB_BASE_ADDR <= n); \ + assert(n < TAB_BASE_ADDR+tab_size); \ + assert(tab_name[n-TAB_BASE_ADDR].inUse); \ + tab_name[n-TAB_BASE_ADDR].inUse = FALSE; \ + /*tab_name[n-TAB_BASE_ADDR].nextFree = free_list; */ \ + /*free_list = n;*/ \ + } \ + \ + type_name proc_name ( void ) \ + { \ + Int i; \ + Int newSz; \ + struct struct_name* newTab; \ + struct struct_name* temp; \ + try_again: \ + if (free_list != TAB_BASE_ADDR-1) { \ + type_name t = free_list; \ + free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree; \ + assert (!(tab_name[t-TAB_BASE_ADDR].inUse)); \ + tab_name[t-TAB_BASE_ADDR].inUse = TRUE; \ + return t; \ + } \ + \ + newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size); \ + if (newSz > TAB_MAX_SIZE) goto cant_allocate; \ + newTab = malloc(newSz * sizeof(struct struct_name)); \ + if (!newTab) goto cant_allocate; \ + for (i = 0; i < tab_size; i++) \ + newTab[i] = tab_name[i]; \ + for (i = tab_size; i < newSz; i++) { \ + newTab[i].inUse = FALSE; \ + newTab[i].nextFree = i-1+TAB_BASE_ADDR; \ + } \ + fprintf(stderr, "Expanding " #type_name \ + "table to size %d\n", newSz ); \ + newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \ + free_list = newSz-1+TAB_BASE_ADDR; \ + tab_size = newSz; \ + temp = tab_name; \ + tab_name = newTab; \ + if (temp) free(temp); \ + goto try_again; \ + \ + cant_allocate: \ + ERRMSG(0) err_msg \ + EEND; \ + } \ + + + +EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName, + nameFL,tabName,tabNameSz, + "Name storage space exhausted", + NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon, + tyconFL,tabTycon,tabTyconSz, + "Type constructor storage space exhausted", + TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass, + classFL,tabClass,tabClassSz, + "Class storage space exhausted", + CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst, + instFL,tabInst,tabInstSz, + "Instance storage space exhausted", + INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule, + moduleFL,tabModule,tabModuleSz, + "Module storage space exhausted", + MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR) + +#ifdef DEBUG_STORAGE +struct strName* generate_name_ref ( Cell nm ) +{ + assert(isName(nm)); + nm -= NAME_BASE_ADDR; + assert(tabName[nm].inUse); + assert(isModule(tabName[nm].mod)); + return & tabName[nm]; +} +struct strTycon* generate_tycon_ref ( Cell tc ) +{ + assert(isTycon(tc) || isTuple(tc)); + tc -= TYCON_BASE_ADDR; + assert(tabTycon[tc].inUse); + assert(isModule(tabTycon[tc].mod)); + return & tabTycon[tc]; +} +struct strClass* generate_cclass_ref ( Cell cl ) +{ + assert(isClass(cl)); + cl -= CCLASS_BASE_ADDR; + assert(tabClass[cl].inUse); + assert(isModule(tabClass[cl].mod)); + return & tabClass[cl]; +} +struct strInst* generate_inst_ref ( Cell in ) +{ + assert(isInst(in)); + in -= INST_BASE_ADDR; + assert(tabInst[in].inUse); + assert(isModule(tabInst[in].mod)); + return & tabInst[in]; +} +struct strModule* generate_module_ref ( Cell mo ) +{ + assert(isModule(mo)); + mo -= MODULE_BASE_ADDR; + assert(tabModule[mo].inUse); + return & tabModule[mo]; +} +#endif + + /* -------------------------------------------------------------------------- * Tycon storage: * @@ -462,38 +612,50 @@ Text t; { * ------------------------------------------------------------------------*/ #define TYCONHSZ 256 /* Size of Tycon hash table*/ -#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */ -static Tycon tyconHw; /* next unused Tycon */ -static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */ -struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */ - -Tycon newTycon(t) /* add new tycon to tycon table */ -Text t; { - Int h = tHash(t); - if (tyconHw-TYCMIN >= NUM_TYCON) { - ERRMSG(0) "Type constructor storage space exhausted" - EEND; - } - tycon(tyconHw).text = t; /* clear new tycon record */ - tycon(tyconHw).kind = NIL; - tycon(tyconHw).defn = NIL; - tycon(tyconHw).what = NIL; - tycon(tyconHw).conToTag = NIL; - tycon(tyconHw).tagToCon = NIL; - tycon(tyconHw).tuple = -1; - tycon(tyconHw).mod = currentModule; - tycon(tyconHw).itbl = NULL; - module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); - tycon(tyconHw).nextTyconHash = tyconHash[h]; - tyconHash[h] = tyconHw; - - return tyconHw++; + //#define tHash(x) (((x)-TEXT_BASE_ADDR)%TYCONHSZ)/* Tycon hash function */ +static int tHash(Text x) +{ + int r; + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + r= x%TYCONHSZ; + assert(r>=0); + assert(r= 0 && x < TYCONHSZ); + return x; +} +Tycon newTycon ( Text t ) /* add new tycon to tycon table */ +{ + Int h = tHash(t); + Tycon tc = allocNewTycon(); + tabTycon + [tc-TYCON_BASE_ADDR].tuple = -1; + tabTycon + [tc-TYCON_BASE_ADDR].mod = currentModule; + tycon(tc).text = t; /* clear new tycon record */ + tycon(tc).kind = NIL; + tycon(tc).defn = NIL; + tycon(tc).what = NIL; + tycon(tc).conToTag = NIL; + tycon(tc).tagToCon = NIL; + tycon(tc).itbl = NULL; + tycon(tc).arity = 0; + module(currentModule).tycons = cons(tc,module(currentModule).tycons); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; + return tc; } Tycon findTycon(t) /* locate Tycon in tycon table */ Text t; { - Tycon tc = tyconHash[tHash(t)]; - + Tycon tc = tyconHash[RC_T(tHash(t))]; +assert(isTycon(tc) || isTuple(tc) || isNull(tc)); while (nonNull(tc) && tycon(tc).text!=t) tc = tycon(tc).nextTyconHash; return tc; @@ -502,7 +664,7 @@ Text t; { Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */ Tycon tc; { Tycon oldtc; - assert(whatIs(tc)==TYCON || whatIs(tc)==TUPLE); + assert(isTycon(tc) || isTuple(tc)); oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { hashTycon(tc); @@ -514,16 +676,18 @@ Tycon tc; { static Void local hashTycon(tc) /* Insert Tycon into hash table */ Tycon tc; { - if (!(isTycon(tc) || isTuple(tc))) { - printf("\nbad stuff: " ); print(tc,10); printf("\n"); - assert(isTycon(tc) || isTuple(tc)); - } - if (1) { - Text t = tycon(tc).text; - Int h = tHash(t); - tycon(tc).nextTyconHash = tyconHash[h]; - tyconHash[h] = tc; + Text t; + Int h; + assert(isTycon(tc) || isTuple(tc)); + {int i; for (i = 0; i < TYCONHSZ; i++) + assert (tyconHash[i] == 0 + || isTycon(tyconHash[i]) + || isTuple(tyconHash[i])); } + t = tycon(tc).text; + h = tHash(t); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; } Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */ @@ -590,10 +754,12 @@ List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */ String pat; /* to list of Tycons ts */ List ts; { /* Null pattern matches every tycon*/ Tycon tc; /* (Tycons with NIL kind excluded) */ - for (tc=TYCMIN; tc= NUM_TUPLES) internal("mkTuple: request for tuple of unsupported size"); - for (i = TYCMIN; i < tyconHw; i++) - if (tycon(i).tuple == n) return i; + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; internal("mkTuple: request for non-existent tuple"); } @@ -645,42 +813,68 @@ Tycon mkTuple ( Int n ) * ------------------------------------------------------------------------*/ #define NAMEHSZ 256 /* Size of Name hash table */ -#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */ - Name nameHw; /* next unused name */ -static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */ -struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */ - -Name newName(t,parent) /* Add new name to name table */ -Text t; -Cell parent; { +//#define nHash(x) (((x)-TEXT_BASE_ADDR)%NAMEHSZ) /* hash fn :: Text->Int */ +static int nHash(Text x) +{ + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + return x%NAMEHSZ; +} +static Name nameHash[NAMEHSZ]; /* Hash table storage */ +int RC_N ( int x ) +{ + assert (x >= 0 && x < NAMEHSZ); + return x; +} +void hashSanity ( void ) +{ + Int i, j; + for (i = 0; i < TYCONHSZ; i++) { + j = tyconHash[i]; + while (nonNull(j)) { + assert(isTycon(j) || isTuple(j)); + j = tycon(j).nextTyconHash; + } + } + for (i = 0; i < NAMEHSZ; i++) { + j = nameHash[i]; + while (nonNull(j)) { + assert(isName(j)); + j = name(j).nextNameHash; + } + } +} + +Name newName ( Text t, Cell parent ) /* Add new name to name table */ +{ Int h = nHash(t); - if (nameHw-NAMEMIN >= NUM_NAME) { - ERRMSG(0) "Name storage space exhausted" - EEND; - } - name(nameHw).text = t; /* clear new name record */ - name(nameHw).line = 0; - name(nameHw).syntax = NO_SYNTAX; - name(nameHw).parent = parent; - name(nameHw).arity = 0; - name(nameHw).number = EXECNAME; - name(nameHw).defn = NIL; - name(nameHw).stgVar = NIL; - name(nameHw).callconv = NIL; - name(nameHw).type = NIL; - name(nameHw).primop = 0; - name(nameHw).mod = currentModule; - name(nameHw).itbl = NULL; - module(currentModule).names=cons(nameHw,module(currentModule).names); - name(nameHw).nextNameHash = nameHash[h]; - nameHash[h] = nameHw; - return nameHw++; + Name nm = allocNewName(); + tabName + [nm-NAME_BASE_ADDR].mod = currentModule; + name(nm).text = t; /* clear new name record */ + name(nm).line = 0; + name(nm).syntax = NO_SYNTAX; + name(nm).parent = parent; + name(nm).arity = 0; + name(nm).number = EXECNAME; + name(nm).defn = NIL; + name(nm).stgVar = NIL; + name(nm).callconv = NIL; + name(nm).type = NIL; + name(nm).primop = NULL; + name(nm).itbl = NULL; + module(currentModule).names = cons(nm,module(currentModule).names); + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; + return nm; } Name findName(t) /* Locate name in name table */ Text t; { - Name n = nameHash[nHash(t)]; - + Name n = nameHash[RC_N(nHash(t))]; +assert(isText(t)); +assert(isName(n) || isNull(n)); while (nonNull(n) && name(n).text!=t) n = name(n).nextNameHash; return n; @@ -689,7 +883,7 @@ Text t; { Name addName(nm) /* Insert Name in name table - if */ Name nm; { /* no clash is caused */ Name oldnm; - assert(whatIs(nm)==NAME); + assert(isName(nm)); oldnm = findName(name(nm).text); if (isNull(oldnm)) { hashName(nm); @@ -706,8 +900,8 @@ Name nm; { assert(isName(nm)); t = name(nm).text; h = nHash(t); - name(nm).nextNameHash = nameHash[h]; - nameHash[h] = nm; + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; } Name findQualName(id) /* Locate (possibly qualified) name*/ @@ -756,8 +950,10 @@ Cell id; { /* in name table */ Name nameFromStgVar ( StgVar v ) { Int n; - for (n = NAMEMIN; n < nameHw; n++) - if (name(n).stgVar == v) return n; + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).stgVar == v) return n; return NIL; } @@ -766,9 +962,11 @@ void* getHugs_AsmObject_for ( char* s ) StgVar v; Text t = findText(s); Name n = NIL; - for (n = NAMEMIN; n < nameHw; n++) - if (name(n).text == t) break; - if (n == nameHw) { + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).text == t) break; + if (n == NAME_BASE_ADDR+tabNameSz) { fprintf ( stderr, "can't find `%s' in ...\n", s ); internal("getHugs_AsmObject_for(1)"); } @@ -828,8 +1026,10 @@ Tycon addTupleTycon ( Int n ) Module m; Name nm; - for (i = TYCMIN; i < tyconHw; i++) - if (tycon(i).tuple == n) return i; + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; if (combined) m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else @@ -945,13 +1145,17 @@ List addNamesMatching(pat,ns) /* Add names matching pattern pat */ String pat; /* to list of names ns */ List ns; { /* Null pattern matches every name */ Name nm; /* (Names with NIL type, or hidden */ + /* or invented names are excluded) */ #if 1 - for (nm=NAMEMIN; nm= NUM_CLASSES) { - ERRMSG(0) "Class storage space exhausted" - EEND; - } - cclass(classHw).text = t; - cclass(classHw).arity = 0; - cclass(classHw).kinds = NIL; - cclass(classHw).head = NIL; - cclass(classHw).fds = NIL; - cclass(classHw).xfds = NIL; - cclass(classHw).dcon = NIL; - cclass(classHw).supers = NIL; - cclass(classHw).dsels = NIL; - cclass(classHw).members = NIL; - cclass(classHw).defaults = NIL; - cclass(classHw).instances = NIL; - classes=cons(classHw,classes); - cclass(classHw).mod = currentModule; - module(currentModule).classes=cons(classHw,module(currentModule).classes); - return classHw++; -} - -Class classMax() { /* Return max Class in use ... */ - return classHw; /* This is a bit ugly, but it's not*/ -} /* worth a lot of effort right now */ +Class newClass ( Text t ) /* add new class to class table */ +{ + Class cl = allocNewClass(); + tabClass + [cl-CCLASS_BASE_ADDR].mod = currentModule; + cclass(cl).text = t; + cclass(cl).arity = 0; + cclass(cl).kinds = NIL; + cclass(cl).head = NIL; + cclass(cl).fds = NIL; + cclass(cl).xfds = NIL; + cclass(cl).dcon = NIL; + cclass(cl).supers = NIL; + cclass(cl).dsels = NIL; + cclass(cl).members = NIL; + cclass(cl).defaults = NIL; + cclass(cl).instances = NIL; + classes = cons(cl,classes); + module(currentModule).classes + = cons(cl,module(currentModule).classes); + return cl; +} Class findClass(t) /* look for named class in table */ Text t; { @@ -1114,18 +1308,15 @@ Cell c; { /* class in class list */ } Inst newInst() { /* Add new instance to table */ - if (instHw-INSTMIN >= NUM_INSTS) { - ERRMSG(0) "Instance storage space exhausted" - EEND; - } - inst(instHw).kinds = NIL; - inst(instHw).head = NIL; - inst(instHw).specifics = NIL; - inst(instHw).implements = NIL; - inst(instHw).builder = NIL; - inst(instHw).mod = currentModule; - - return instHw++; + Inst in = allocNewInst(); + tabInst + [in-INST_BASE_ADDR].mod = currentModule; + inst(in).kinds = NIL; + inst(in).head = NIL; + inst(in).specifics = NIL; + inst(in).implements = NIL; + inst(in).builder = NIL; + return in; } #ifdef DEBUG_DICTS @@ -1141,14 +1332,17 @@ Inst in; { Inst findFirstInst(tc) /* look for 1st instance involving */ Tycon tc; { /* the type constructor tc */ - return findNextInst(tc,INSTMIN-1); + return findNextInst(tc,INST_BASE_ADDR-1); } Inst findNextInst(tc,in) /* look for next instance involving*/ Tycon tc; /* the type constructor tc */ Inst in; { /* starting after instance in */ - while (++in < instHw) { - Cell pi = inst(in).head; + Cell pi; + while (++in < INST_BASE_ADDR+tabInstSz) { + if (!tabInst[in-INST_BASE_ADDR].inUse) continue; + assert(isModule(inst(in).mod)); + pi = inst(in).head; for (; isAp(pi); pi=fun(pi)) if (typeInvolves(arg(pi),tc)) return in; @@ -1185,20 +1379,21 @@ Class findQualClassWithoutConsultingExportList ( QualId q ) t_class = qtextOf(q); } - for (cl = CLASSMIN; cl < classHw; cl++) { - if (cclass(cl).text == t_class) { - /* Class name is ok, but is this the right module? */ - if (isNull(t_mod) /* no module name specified */ - || (nonNull(t_mod) - && t_mod == module(cclass(cl).mod).text) - ) - return cl; - } + for (cl = CCLASS_BASE_ADDR; + cl < CCLASS_BASE_ADDR+tabClassSz; cl++) { + if (tabClass[cl-CCLASS_BASE_ADDR].inUse) + if (cclass(cl).text == t_class) { + /* Class name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(cclass(cl).mod).text) + ) + return cl; + } } return NIL; } - /* Same deal, except for Tycons. */ Tycon findQualTyconWithoutConsultingExportList ( QualId q ) { @@ -1216,43 +1411,21 @@ Tycon findQualTyconWithoutConsultingExportList ( QualId q ) t_tycon = qtextOf(q); } - for (tc = TYCMIN; tc < tyconHw; tc++) { - if (tycon(tc).text == t_tycon) { - /* Tycon name is ok, but is this the right module? */ - if (isNull(t_mod) /* no module name specified */ - || (nonNull(t_mod) - && t_mod == module(tycon(tc).mod).text) - ) - return tc; - } + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + if (tycon(tc).text == t_tycon) { + /* Tycon name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(tycon(tc).mod).text) + ) + return tc; + } } return NIL; } -Tycon findTyconInAnyModule ( Text t ) -{ - Tycon tc; - for (tc = TYCMIN; tc < tyconHw; tc++) - if (tycon(tc).text == t) return tc; - return NIL; -} - -Class findClassInAnyModule ( Text t ) -{ - Class cc; - for (cc = CLASSMIN; cc < classHw; cc++) - if (cclass(cc).text == t) return cc; - return NIL; -} - -Name findNameInAnyModule ( Text t ) -{ - Name nm; - for (nm = NAMEMIN; nm < nameHw; nm++) - if (name(nm).text == t) return nm; - return NIL; -} - /* Same deal, except for Names. */ Name findQualNameWithoutConsultingExportList ( QualId q ) { @@ -1270,36 +1443,75 @@ Name findQualNameWithoutConsultingExportList ( QualId q ) t_name = qtextOf(q); } - for (nm = NAMEMIN; nm < nameHw; nm++) { - if (name(nm).text == t_name) { - /* Name is ok, but is this the right module? */ - if (isNull(t_mod) /* no module name specified */ - || (nonNull(t_mod) - && t_mod == module(name(nm).mod).text) - ) - return nm; - } + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) { + if (tabName[nm-NAME_BASE_ADDR].inUse) + if (name(nm).text == t_name) { + /* Name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(name(nm).mod).text) + ) + return nm; + } } return NIL; } +Tycon findTyconInAnyModule ( Text t ) +{ + Tycon tc; + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + if (tycon(tc).text == t) return tc; + return NIL; +} + +Class findClassInAnyModule ( Text t ) +{ + Class cc; + for (cc = CCLASS_BASE_ADDR; + cc < CCLASS_BASE_ADDR+tabClassSz; cc++) + if (tabClass[cc-CCLASS_BASE_ADDR].inUse) + if (cclass(cc).text == t) return cc; + return NIL; +} + +Name findNameInAnyModule ( Text t ) +{ + Name nm; + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) + if (tabName[nm-NAME_BASE_ADDR].inUse) + if (name(nm).text == t) return nm; + return NIL; +} + + /* returns List of QualId */ List getAllKnownTyconsAndClasses ( void ) { Tycon tc; Class nw; List xs = NIL; - for (tc = TYCMIN; tc < tyconHw; tc++) { - /* almost certainly undue paranoia about duplicate avoidance, but .. */ - QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text ); - if (!qualidIsMember(q,xs)) - xs = cons ( q, xs ); + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) { + /* almost certainly undue paranoia about duplicate avoidance */ + QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } } - for (nw = CLASSMIN; nw < classHw; nw++) { - QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text ); - if (!qualidIsMember(q,xs)) - xs = cons ( q, xs ); + for (nw = CCLASS_BASE_ADDR; + nw < CCLASS_BASE_ADDR+tabClassSz; nw++) { + if (tabClass[nw-CCLASS_BASE_ADDR].inUse) { + QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } } return xs; } @@ -1308,15 +1520,18 @@ List getAllKnownTyconsAndClasses ( void ) void locateSymbolByName ( Text t ) { Int i; - for (i = NAMEMIN; i < nameHw; i++) - if (name(i).text == t) - fprintf ( stderr, "name(%d)\n", i-NAMEMIN); - for (i = TYCMIN; i < tyconHw; i++) - if (tycon(i).text == t) - fprintf ( stderr, "tycon(%d)\n", i-TYCMIN); - for (i = CLASSMIN; i < classHw; i++) - if (cclass(i).text == t) - fprintf ( stderr, "class(%d)\n", i-CLASSMIN); + for (i = NAME_BASE_ADDR; + i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t) + fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR); + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t) + fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR); + for (i = CCLASS_BASE_ADDR; + i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t) + fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR); } /* -------------------------------------------------------------------------- @@ -1326,51 +1541,14 @@ void locateSymbolByName ( Text t ) * operations are defined as macros, expanded inline. * ------------------------------------------------------------------------*/ -Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */ +Cell cellStack[NUM_STACK]; /* Storage for cells on stack */ StackPtr sp; /* stack pointer */ -#if GIMME_STACK_DUMPS - -#define UPPER_DISP 5 /* # display entries on top of stack */ -#define LOWER_DISP 5 /* # display entries on bottom of stack*/ - -Void hugsStackOverflow() { /* Report stack overflow */ - extern Int rootsp; - extern Cell evalRoots[]; - - ERRMSG(0) "Control stack overflow" ETHEN - if (rootsp>=0) { - Int i; - if (rootsp>=UPPER_DISP+LOWER_DISP) { - for (i=0; i=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - else { - for (i=rootsp; i>=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - } - ERRTEXT "\n" - EEND; -} - -#else /* !GIMME_STACK_DUMPS */ - Void hugsStackOverflow() { /* Report stack overflow */ ERRMSG(0) "Control stack overflow" EEND; } -#endif /* !GIMME_STACK_DUMPS */ /* -------------------------------------------------------------------------- * Module storage: @@ -1389,32 +1567,100 @@ Void hugsStackOverflow() { /* Report stack overflow */ * * ------------------------------------------------------------------------*/ -static Module moduleHw; /* next unused Module */ -struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */ Module currentModule; /* Module currently being processed*/ -Bool isValidModule(m) /* is m a legitimate module id? */ +Bool isValidModule(m) /* is m a legitimate module id? */ Module m; { - return (MODMIN <= m && m < moduleHw); + return isModule(m); } -Module newModule(t) /* add new module to module table */ -Text t; { - if (moduleHw-MODMIN >= NUM_MODULE) { - ERRMSG(0) "Module storage space exhausted" - EEND; - } - module(moduleHw).text = t; /* clear new module record */ - module(moduleHw).qualImports = NIL; - module(moduleHw).fake = FALSE; - module(moduleHw).exports = NIL; - module(moduleHw).tycons = NIL; - module(moduleHw).names = NIL; - module(moduleHw).classes = NIL; - module(moduleHw).object = NULL; - module(moduleHw).objectExtras = NULL; - module(moduleHw).objectExtraNames = NIL; - return moduleHw++; +Module newModule ( Text t ) /* add new module to module table */ +{ + Module mod = allocNewModule(); + module(mod).text = t; /* clear new module record */ + + module(mod).tycons = NIL; + module(mod).names = NIL; + module(mod).classes = NIL; + module(mod).exports = NIL; + module(mod).qualImports = NIL; + module(mod).fake = FALSE; + + module(mod).tree = NIL; + module(mod).completed = FALSE; + module(mod).lastStamp = 0; /* ???? */ + + module(mod).fromSrc = TRUE; + module(mod).srcExt = findText(""); + module(mod).uses = NIL; + + module(mod).objName = findText(""); + module(mod).objSize = 0; + + module(mod).object = NULL; + module(mod).objectExtras = NULL; + module(mod).objectExtraNames = NIL; + return mod; +} + +void nukeModule ( Module m ) +{ + ObjectCode* oc; + ObjectCode* oc2; + Int i; +assert(isModule(m)); +fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); + oc = module(m).object; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + oc = module(m).objectExtras; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + + for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) { + if (name(i).itbl) free(name(i).itbl); + name(i).itbl = NULL; + freeName(i); + } + + for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) { + if (tycon(i).itbl) free(tycon(i).itbl); + tycon(i).itbl = NULL; + freeTycon(i); + } + + for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse) { + if (cclass(i).mod == m) { + freeClass(i); + } else { + List /* Inst */ ins; + List /* Inst */ ins2 = NIL; + for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins)) + if (inst(hd(ins)).mod != m) + ins2 = cons(hd(ins),ins2); + cclass(i).instances = ins2; + } + } + + + for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++) + if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m) + freeInst(i); + + freeModule(m); + //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0; + //for (i = 0; i < NAMEHSZ; i++) nameHash[i] = 0; + //classes = NIL; + //hashSanity(); } void ppModules ( void ) @@ -1422,10 +1668,12 @@ void ppModules ( void ) Int i; fflush(stderr); fflush(stdout); printf ( "begin MODULES\n" ); - for (i = moduleHw-1; i >= MODMIN; i--) - printf ( " %2d: %16s\n", - i-MODMIN, textToStr(module(i).text) - ); + for (i = MODULE_BASE_ADDR+tabModuleSz-1; + i >= MODULE_BASE_ADDR; i--) + if (tabModule[i-MODULE_BASE_ADDR].inUse) + printf ( " %2d: %16s\n", + i-MODULE_BASE_ADDR, textToStr(module(i).text) + ); printf ( "end MODULES\n" ); fflush(stderr); fflush(stdout); } @@ -1434,9 +1682,11 @@ void ppModules ( void ) Module findModule(t) /* locate Module in module table */ Text t; { Module m; - for(m=MODMIN; mnext) { - void* ad = ocLookupSym ( oc, sym ); - if (ad) return ad; - } + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) { + if (tabModule[m-MODULE_BASE_ADDR].inUse) + for (oc = module(m).objectExtras; oc; oc=oc->next) { + void* ad = ocLookupSym ( oc, sym ); + if (ad) return ad; + } } return NULL; } @@ -1548,16 +1810,19 @@ OSectionKind lookupSection ( void* ad ) ObjectCode* oc; OSectionKind sect; - for (m=MODMIN; mnext) { - sect = ocLookupSection ( oc, ad ); - if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) - return sect; + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) { + if (tabModule[m-MODULE_BASE_ADDR].inUse) { + if (module(m).object) { + sect = ocLookupSection ( module(m).object, ad ); + if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) + return sect; + } + for (oc = module(m).objectExtras; oc; oc=oc->next) { + sect = ocLookupSection ( oc, ad ); + if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) + return sect; + } } } return HUGS_SECTIONKIND_OTHER; @@ -1565,218 +1830,6 @@ OSectionKind lookupSection ( void* ad ) /* -------------------------------------------------------------------------- - * Script file storage: - * - * script files are read into the system one after another. The state of - * the stored data structures (except the garbage-collected heap) is recorded - * before reading a new script. In the event of being unable to read the - * script, or if otherwise requested, the system can be restored to its - * original state immediately before the file was read. - * ------------------------------------------------------------------------*/ - -typedef struct { /* record of storage state prior to */ - Text file; /* reading script/module */ - Text textHw; - Text nextNewText; - Text nextNewDText; - Module moduleHw; - Tycon tyconHw; - Name nameHw; - Class classHw; - Inst instHw; -#if TREX - Ext extHw; -#endif -} script; - -#ifdef DEBUG_SHOWUSE -static Void local showUse(msg,val,mx) -String msg; -Int val, mx; { - Printf("%6s : %5d of %5d (%2d%%)\n",msg,val,mx,(100*val)/mx); -} -#endif - -static Script scriptHw; /* next unused script number */ -static script scripts[NUM_SCRIPTS]; /* storage for script records */ - - -void ppScripts ( void ) -{ - Int i; - fflush(stderr); fflush(stdout); - printf ( "begin SCRIPTS\n" ); - for (i = scriptHw-1; i >= 0; i--) - printf ( " %2d: %16s tH=%d mH=%d yH=%d " - "nH=%d cH=%d iH=%d nnS=%d,%d\n", - i, textToStr(scripts[i].file), - scripts[i].textHw, scripts[i].moduleHw, - scripts[i].tyconHw, scripts[i].nameHw, - scripts[i].classHw, scripts[i].instHw, - scripts[i].nextNewText, scripts[i].nextNewDText - ); - printf ( "end SCRIPTS\n" ); - fflush(stderr); fflush(stdout); -} - -Script startNewScript(f) /* start new script, keeping record */ -String f; { /* of status for later restoration */ - if (scriptHw >= NUM_SCRIPTS) { - ERRMSG(0) "Too many script files in use" - EEND; - } -#ifdef DEBUG_SHOWUSE - showUse("Text", textHw, NUM_TEXT); - showUse("Module", moduleHw-MODMIN, NUM_MODULE); - showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON); - showUse("Name", nameHw-NAMEMIN, NUM_NAME); - showUse("Class", classHw-CLASSMIN, NUM_CLASSES); - showUse("Inst", instHw-INSTMIN, NUM_INSTS); -#if TREX - showUse("Ext", extHw-EXTMIN, NUM_EXT); -#endif -#endif - scripts[scriptHw].file = findText( f ? f : "" ); - scripts[scriptHw].textHw = textHw; - scripts[scriptHw].nextNewText = nextNewText; - scripts[scriptHw].nextNewDText = nextNewDText; - scripts[scriptHw].moduleHw = moduleHw; - scripts[scriptHw].tyconHw = tyconHw; - scripts[scriptHw].nameHw = nameHw; - scripts[scriptHw].classHw = classHw; - scripts[scriptHw].instHw = instHw; -#if TREX - scripts[scriptHw].extHw = extHw; -#endif - return scriptHw++; -} - -Bool isPreludeScript() { /* Test whether this is the Prelude*/ - return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ ); -} - -Bool moduleThisScript(m) /* Test if given module is defined */ -Module m; { /* in current script file */ - return scriptHw < 1 - || m>=scripts[scriptHw-1].moduleHw; -} - -Module lastModule() { /* Return module in current script file */ - return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude); -} - -#define scriptThis(nm,t,tag) Script nm(x) \ - t x; { \ - Script s=0; \ - while (s=scripts[s].tag) \ - s++; \ - return s; \ - } -scriptThis(scriptThisName,Name,nameHw) -scriptThis(scriptThisTycon,Tycon,tyconHw) -scriptThis(scriptThisInst,Inst,instHw) -scriptThis(scriptThisClass,Class,classHw) -#undef scriptThis - -Module moduleOfScript(s) -Script s; { - return (s==0) ? modulePrelude : scripts[s-1].moduleHw; -} - -String fileOfModule(m) -Module m; { - Script s; - if (m == modulePrelude) { - return STD_PRELUDE; - } - for(s=0; s= scripts[sno].moduleHw; --i) { - if (module(i).objectFile) { - printf("[bogus] closing objectFile for module %d\n",i); - /*dlclose(module(i).objectFile);*/ - } - } - moduleHw = scripts[sno].moduleHw; -#endif - for (i=0; i=BCSTAG) { + else if (isNull(fst(c)) || isTagPtr(fst(c))) { STACK_CHECK markSnd(c); } @@ -1934,7 +1977,7 @@ ma: t = c; /* Keep pointer to original pair */ fst(c) = markCell(fst(c)); goto ma; } - else if (isNull(fst(c)) || fst(c)>=BCSTAG) + else if (isNull(fst(c)) || isTagPtr(fst(c))) goto ma; return; } @@ -1955,8 +1998,9 @@ Void garbageCollect() { /* Run garbage collector ... */ register Int mask; register Int place; Int recovered; - jmp_buf regs; /* save registers on stack */ +fprintf ( stderr, "wa-hey! garbage collection! too difficult! bye!\n" ); +exit(0); setjmp(regs); gcStarted(); @@ -2014,14 +2058,14 @@ static Cell lastExprSaved; /* last expression to be saved */ Void setLastExpr(e) /* save expression for later recall*/ Cell e; { lastExprSaved = NIL; /* in case attempt to save fails */ - savedText = NUM_TEXT; + savedText = TEXT_SIZE; lastExprSaved = lowLevelLastIn(e); } static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */ Cell c; { /* acyclic graph) for later recall */ if (isPair(c)) { /* Duplicating any text strings */ - if (isBoxTag(fst(c))) /* in case these are lost at some */ + if (isTagNonPtr(fst(c))) /* in case these are lost at some */ switch (fst(c)) { /* point before the expr is reused */ case VARIDCELL : case VAROPCELL : @@ -2049,7 +2093,7 @@ Cell getLastExpr() { /* recover previously saved expr */ static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */ Cell c; { /* except that Cells refering to */ if (isPair(c)) { /* Text values are restored to */ - if (isBoxTag(fst(c))) /* appropriate values */ + if (isTagNonPtr(fst(c))) /* appropriate values */ switch (fst(c)) { case VARIDCELL : case VAROPCELL : @@ -2074,10 +2118,32 @@ Cell c; { /* except that Cells refering to */ * Miscellaneous operations on heap cells: * ------------------------------------------------------------------------*/ -/* Profiling suggests that the number of calls to whatIs() is typically */ -/* rather high. The recoded version below attempts to improve the average */ -/* performance for whatIs() using a binary search for part of the analysis */ +Cell whatIs ( register Cell c ) +{ + if (isPair(c)) { + register Cell fstc = fst(c); + return isTag(fstc) ? fstc : AP; + } + if (isOffset(c)) return OFFSET; + if (isChar(c)) return CHARCELL; + if (isInt(c)) return INTCELL; + if (isName(c)) return NAME; + if (isTycon(c)) return TYCON; + if (isTuple(c)) return TUPLE; + if (isClass(c)) return CLASS; + if (isInst(c)) return INSTANCE; + if (isModule(c)) return MODULE; + if (isText(c)) return TEXTCELL; + if (isInventedVar(c)) return INVAR; + if (isInventedDictVar(c)) return INDVAR; + if (isSpec(c)) return c; + if (isNull(c)) return c; + fprintf ( stderr, "whatIs: unknown %d\n", c ); + internal("whatIs"); +} + +#if 0 Cell whatIs(c) /* identify type of cell */ register Cell c; { if (isPair(c)) { @@ -2104,6 +2170,7 @@ register Cell c; { else return TUPLE; #endif + /* if (isPair(c)) { register Cell fstc = fst(c); return isTag(fstc) ? fstc : AP; @@ -2122,6 +2189,8 @@ register Cell c; { if (c>=TUPMIN) return TUPLE; return c;*/ } +#endif + /* A very, very simple printer. * Output is uglier than from printExp - but the printer is more @@ -2132,7 +2201,29 @@ Void print ( Cell c, Int depth ) { if (0 == depth) { Printf("..."); - } else { + } + else if (isNull(c)) { + Printf("NIL"); + } + else if (isTagPtr(c)) { + Printf("TagP(%d)", c); + } + else if (isTagNonPtr(c)) { + Printf("TagNP(%d)", c); + } + else if (isSpec(c)) { + Printf("TagS(%d)", c); + } + else if (isText(c)) { + Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c)); + } + else if (isInventedVar(c)) { + Printf("invented(%d)", c-INVAR_BASE_ADDR); + } + else if (isInventedDictVar(c)) { + Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR); + } + else { Int tag = whatIs(c); switch (tag) { case AP: @@ -2158,27 +2249,23 @@ Void print ( Cell c, Int depth ) Printf("ptr(%p)",ptrOf(c)); break; case CLASS: - Printf("class(%d)", c-CLASSMIN); - if (CLASSMIN <= c && c < classHw) { - Printf("=\"%s\"", textToStr(cclass(c).text)); - } + Printf("class(%d)", c-CCLASS_BASE_ADDR); + Printf("=\"%s\"", textToStr(cclass(c).text)); break; case INSTANCE: - Printf("instance(%d)", c - INSTMIN); + Printf("instance(%d)", c - INST_BASE_ADDR); break; case NAME: - Printf("name(%d)", c-NAMEMIN); - if (NAMEMIN <= c && c < nameHw) { - Printf("=\"%s\"", textToStr(name(c).text)); - } + Printf("name(%d)", c-NAME_BASE_ADDR); + Printf("=\"%s\"", textToStr(name(c).text)); break; case TYCON: - Printf("tycon(%d)", c-TYCMIN); - if (TYCMIN <= c && c < tyconHw) - Printf("=\"%s\"", textToStr(tycon(c).text)); + Printf("tycon(%d)", c-TYCON_BASE_ADDR); + Printf("=\"%s\"", textToStr(tycon(c).text)); break; case MODULE: - Printf("module(%d)", c - MODMIN); + Printf("module(%d)", c - MODULE_BASE_ADDR); + Printf("=\"%s\"", textToStr(module(c).text)); break; case OFFSET: Printf("Offset %d", offsetOf(c)); @@ -2204,9 +2291,6 @@ Void print ( Cell c, Int depth ) } Printf(")"); break; - case NIL: - Printf("NIL"); - break; case WILDCARD: Printf("_"); break; @@ -2338,10 +2422,10 @@ Void print ( Cell c, Int depth ) Putchar(')'); break; default: - if (isBoxTag(tag)) { - Printf("Tag(%d)=%d", c, tag); - } else if (isConTag(tag)) { - Printf("%d@(%d,",c,tag); + if (isTagNonPtr(tag)) { + Printf("(TagNP=%d,%d)", c, tag); + } else if (isTagPtr(tag)) { + Printf("(TagP=%d,",tag); print(snd(c), depth-1); Putchar(')'); break; @@ -2432,13 +2516,14 @@ Cell c; { Int intOf(c) /* find integer value of cell? */ Cell c; { assert(isInt(c)); - return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO); + return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO); } Cell mkInt(n) /* make cell representing integer */ Int n; { - return (MINSMALLINT <= n && n <= MAXSMALLINT) - ? INTZERO+n + return (SMALL_INT_MIN <= SMALL_INT_ZERO+n && + SMALL_INT_ZERO+n <= SMALL_INT_MAX) + ? SMALL_INT_ZERO+n : pair(INTCELL,n); } @@ -2764,7 +2849,7 @@ List xs; { /* non destructive */ /* -------------------------------------------------------------------------- - * Strongly-typed lists (z-lists) and tuples (experimental) + * Tagged tuples (experimental) * ------------------------------------------------------------------------*/ static void z_tag_check ( Cell x, int tag, char* caller ) @@ -2782,61 +2867,6 @@ static void z_tag_check ( Cell x, int tag, char* caller ) } } -#if 0 -Cell zcons ( Cell x, Cell xs ) -{ - if (!(isNull(xs) || whatIs(xs)==ZCONS)) - internal("zcons: ill typed tail"); - return ap(ZCONS,ap(x,xs)); -} - -Cell zhd ( Cell xs ) -{ - if (isNull(xs)) internal("zhd: empty list"); - z_tag_check(xs,ZCONS,"zhd"); - return fst( snd(xs) ); -} - -Cell ztl ( Cell xs ) -{ - if (isNull(xs)) internal("ztl: empty list"); - z_tag_check(xs,ZCONS,"zhd"); - return snd( snd(xs) ); -} - -Int zlength ( ZList xs ) -{ - Int n = 0; - while (nonNull(xs)) { - z_tag_check(xs,ZCONS,"zlength"); - n++; - xs = snd( snd(xs) ); - } - return n; -} - -ZList zreverse ( ZList xs ) -{ - ZList rev = NIL; - while (nonNull(xs)) { - z_tag_check(xs,ZCONS,"zreverse"); - rev = zcons(zhd(xs),rev); - xs = ztl(xs); - } - return rev; -} - -Cell zsingleton ( Cell x ) -{ - return zcons (x,NIL); -} - -Cell zdoubleton ( Cell x, Cell y ) -{ - return zcons(x,zcons(y,NIL)); -} -#endif - Cell zpair ( Cell x1, Cell x2 ) { return ap(ZTUP2,ap(x1,x2)); } Cell zfst ( Cell zpair ) @@ -2977,7 +3007,7 @@ static void print100 ( Int x ) void dumpTycon ( Int t ) { - if (isTycon(TYCMIN+t) && !isTycon(t)) t += TYCMIN; + if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR; if (!isTycon(t)) { printf ( "dumpTycon %d: not a tycon\n", t); return; @@ -3003,7 +3033,7 @@ void dumpTycon ( Int t ) void dumpName ( Int n ) { - if (isName(NAMEMIN+n) && !isName(n)) n += NAMEMIN; + if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR; if (!isName(n)) { printf ( "dumpName %d: not a name\n", n); return; @@ -3029,7 +3059,7 @@ void dumpName ( Int n ) void dumpClass ( Int c ) { - if (isClass(CLASSMIN+c) && !isClass(c)) c += CLASSMIN; + if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR; if (!isClass(c)) { printf ( "dumpClass %d: not a class\n", c); return; @@ -3058,7 +3088,7 @@ void dumpClass ( Int c ) void dumpInst ( Int i ) { - if (isInst(INSTMIN+i) && !isInst(i)) i += INSTMIN; + if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR; if (!isInst(i)) { printf ( "dumpInst %d: not an instance\n", i); return; @@ -3081,22 +3111,6 @@ void dumpInst ( Int i ) * storage control: * ------------------------------------------------------------------------*/ -#if DYN_TABLES -static void far* safeFarCalloc ( Int,Int)); -static void far* safeFarCalloc(n,s) /* allocate table storage and check*/ -Int n, s; { /* for non-null return */ - void far* tab = farCalloc(n,s); - if (tab==0) { - ERRMSG(0) "Cannot allocate run-time tables" - EEND; - } - return tab; -} -#define TABALLOC(v,t,n) v=(t far*)safeFarCalloc(n,sizeof(t)); -#else -#define TABALLOC(v,t,n) -#endif - Void storage(what) Int what; { Int i; @@ -3117,59 +3131,77 @@ Int what; { lsave = NIL; rsave = NIL; if (isNull(lastExprSaved)) - savedText = NUM_TEXT; + savedText = TEXT_SIZE; break; case MARK : start(); - for (i=NAMEMIN; i