# --------------------------------------------------------------------------- #
-# $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 = ..
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
* 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"
{
extern Name nameHw;
Name nm;
- for( nm=NAMEMIN; nm<nameHw; ++nm ) {
- StgVar v = name(nm).stgVar;
- if (isStgVar(v)
- && isPtr(stgVarInfo(v))
- && varHasClosure(v)
- && closureOfVar(v) == closure) {
- return textToStr(name(nm).text);
- }
+ for( nm = NAME_BASE_ADDR;
+ nm < NAME_BASE_ADDR+tabNameSz; ++nm )
+ if (name(nm).inUse) {
+ StgVar v = name(nm).stgVar;
+ if (isStgVar(v)
+ && isPtr(stgVarInfo(v))
+ && varHasClosure(v)
+ && closureOfVar(v) == closure) {
+ return textToStr(name(nm).text);
+ }
}
return 0;
}
-/* called at the start of GC */
-void markHugsObjects( void )
-{
- extern Name nameHw;
- Name nm;
- for( nm=NAMEMIN; nm<nameHw; ++nm ) {
- StgVar v = name(nm).stgVar;
- if (isStgVar(v) && isPtr(stgVarInfo(v))) {
- asmMarkObject((AsmClosure*)ptrOf(stgVarInfo(v)));
- }
- }
-}
-
static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
{
setPos(v,asmBind(bco,rep));
con = stgCaseAltCon(hd(alts));
/* special case: dictionary constructors */
- if (strncmp(":D",textToStr(name(con).text),2)==0) {
+ if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
omit_test = TRUE;
goto xyzzy;
}
#endif
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
+ /* printStg( stdout, hd(b) ); printf( "\n\n"); */
beginTop(hd(b));
}
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
- //printStg( stdout, hd(b) ); printf( "\n\n");
+ /* printStg( stdout, hd(b) ); printf( "\n\n"); */
endTop(hd(b));
}
- //mapProc(zap,binds);
+ /* mapProc(zap,binds); */
+}
+
+/* Called by the evaluator's GC to tell Hugs to mark stuff in the
+ run-time heap.
+*/
+void markHugsObjects( void )
+{
+ extern Name nameHw;
+ Name nm;
+ for ( nm = NAME_BASE_ADDR;
+ nm < NAME_BASE_ADDR+tabNameSz; ++nm )
+ if (tabName[nm-NAME_BASE_ADDR].inUse) {
+ StgVar v = name(nm).stgVar;
+ if (isStgVar(v) && isPtr(stgVarInfo(v))) {
+ asmMarkObject(ptrOf(stgVarInfo(v)));
+ }
+ }
}
/* --------------------------------------------------------------------------
* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.31 $
- * $Date: 2000/03/20 04:26:23 $
+ * $Revision: 1.32 $
+ * $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Void consoleInput ( String );
extern Void projInput ( String );
extern Void stringInput ( String );
-extern Void parseScript ( String,Long );
+extern Cell parseModule ( String,Long );
extern Void parseExp ( Void );
#if EXPLAIN_INSTANCE_RESOLUTION
extern Void parseContext ( Void );
extern Void staticAnalysis ( Int );
-extern Void startModule ( Cell );
+extern Void startModule ( Module );
extern Void setExportList ( List );
extern Void setExports ( List );
extern Void addQualImport ( Text,Text );
#if EXPLAIN_INSTANCE_RESOLUTION
extern Void checkContext ( Void );
#endif
-extern Void checkDefns ( Void );
+extern Void checkDefns ( Module );
extern Bool h98Pred ( Bool,Cell );
extern Cell h98Context ( Bool,List );
extern Void h98CheckCtxt ( Int,String,Bool,List,Inst );
* ctrlbrk: set control break handler
*/
-#if HUGS_FOR_WINDOWS
-# define ctrlbrk(bh)
-# define allowBreak() kbhit()
-#else /* !HUGS_FOR_WINDOWS */
-# if HAVE_SIGPROCMASK
-# include <signal.h>
-# define ctrlbrk(bh) { sigset_t mask; \
+#if HAVE_SIGPROCMASK
+#include <signal.h>
+#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;
#else
# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); }
#endif
-#endif /* !HUGS_FOR_WINDOWS */
/*---------------------------------------------------------------------------
#if HAVE_UNISTD_H
# include <sys/types.h>
# include <unistd.h>
-#elif !HUGS_FOR_WINDOWS
-extern int chdir ( const char* );
#endif
+extern int chdir ( const char* );
+
#if HAVE_STDLIB_H
# include <stdlib.h>
#else
*-------------------------------------------------------------------------*/
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 );
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 */
* 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()
#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);
* 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 <setjmp.h>
* 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 );
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 );
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 );
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 );
* ------------------------------------------------------------------------*/
#include "machdep.c"
-#ifdef WANT_TIMER
-#include "timer.c"
-#endif
/* --------------------------------------------------------------------------
* Local data areas:
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) */
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:
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);
}
}
* 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+1<argc) {
- if (proj) {
- ERRMSG(0) "Multiple project filenames on command line"
- EEND;
- } else {
- proj = argv[++i];
- }
- } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
- && !processOption(argv[i])) {
- addStackEntry(argv[i]);
- }
- }
-
-#if DEBUG
- {
- char exe_name[N_INSTALLDIR + 6];
- strcpy(exe_name, installDir);
- strcat(exe_name, "hugs");
- DEBUG_LoadSymbols(exe_name);
- }
-#endif
-
-
-#if 0
- if (!scriptName[0]) {
- Printf("Prelude not found on current path: \"%s\"\n",
- hugsPath ? hugsPath : "");
- fatal("Unable to load prelude");
- }
-#endif
+ if (strcmp(argv[i], "--")==0) break;
+ if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
+ && !processOption(argv[i])) {
+ initialModules
+ = cons ( mkCon(findText(argv[i])), initialModules );
+ }
+ }
- if (haskell98) {
- Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n");
- } else {
- Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n");
- }
+ if (haskell98) {
+ Printf("Haskell 98 mode: Restart with command line option -98"
+ " to enable extensions\n");
+ } else {
+ Printf("Hugs mode: Restart with command line option +98 for"
+ " Haskell 98 mode\n");
+ }
- if (combined) {
- Printf("Combined mode: Restart with command line -c for standalone mode\n\n" );
- } else {
- Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
- }
-
- everybody(PREPREL);
+ if (combined) {
+ Printf("Combined mode: Restart with command line -c for"
+ " standalone mode\n\n" );
+ } else {
+ Printf("Standalone mode: Restart with command line +c for"
+ " combined mode\n\n" );
+ }
- evalModule = findText(""); /* evaluate wrt last module by default */
- if (proj) {
- if (namesUpto>1) {
- fprintf(stderr,
- "\nUsing project file, ignoring additional filenames\n");
- }
- loadProject(strCopy(proj));
- }
- readScripts(0);
+ return initialModules;
}
/* --------------------------------------------------------------------------
Putchar('\n');
}
-#if USE_REGISTRY || HUGS_FOR_WINDOWS
+#if USE_REGISTRY
#define PUTC(c) \
*next++=(c)
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 */
}
}
+
/* --------------------------------------------------------------------------
- * 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<namesUpto; i++)
- if (strcmp(scriptInfo[i].modName,iname)==0)
- break;
- //fprintf(stderr, "import name = %s num = %d\n", iname, i );
-
- if (i<namesUpto) {
- /* We should have filled in the details of each module
- the first time we hear about it.
- */
- assert(scriptInfo[i].details);
- }
- if (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; i<namesUpto; ++i)
- if (scriptName[i])
- free(scriptName[i]);
-#endif
- dropScriptsFrom(scno-1);
- namesUpto = scno;
- if (numScripts>namesUpto)
- 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 (; n<numScripts; n++) { /* Scan previously loaded scripts */
- ppSmStack("readscripts-loop1");
- getFileInfo(scriptName[n], &timeStamp, &fileSize);
- if (timeChanged(timeStamp,lastChange[n])) {
- dropScriptsFrom(n-1);
- numScripts = n;
- break;
- }
- }
- for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
- postponed[n] = FALSE; /* at this stage */
- numScripts = 0;
-
- while (numScripts<namesUpto) { /* Process any remaining scripts */
- ppSmStack("readscripts-loop2");
- getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
- timeSet(lastChange[numScripts],timeStamp);
- if (numScripts>0) /* 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 (; n<numScripts; n++) {
- ppSmStack("readscripts-loop2");
- strcpy(name, scriptInfo[n].path);
- strcat(name, scriptInfo[n].modName);
- if (scriptInfo[n].fromSource)
- strcat(name, scriptInfo[n].srcExt); else
- strcat(name, ".u_hi"); //ToDo: should be .o
- getFileInfo(name,&timeStamp, &fileSize);
- if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
- dropScriptsFrom(n-1);
- numScripts = n;
- break;
- }
- }
- for (; n<NUM_SCRIPTS; n++)
- scriptInfo[n].postponed = FALSE;
+ /* Second, form a simplistic transitive closure of the out-of-date
+ modules: a module is out of date if it imports an out-of-date
+ module.
+ */
+ while (1) {
+ ood_new = NIL;
+ for (t = modgList; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ for (us = module(mod).uses; nonNull(us); us=tl(us))
+ if (varIsMember(textOf(hd(us)),ood))
+ break;
+ if (nonNull(us)) {
+fprintf ( stderr, "new OOD %s\n", textToStr(textOf(hd(t))) );
+ if (varIsMember(textOf(hd(t)),prelModules))
+ Printf ( "warning: prelude module \"%s\" is out-of-date\n",
+ textToStr(textOf(hd(t))) );
+ else
+ if (!varIsMember(textOf(hd(t)),ood_new) &&
+ !varIsMember(textOf(hd(t)),ood))
+ ood_new = cons(hd(t),ood_new);
+ }
+ }
+printf ( "\nood_new = " );print(ood_new,100);
+printf ( "\nood = " );print(ood,100); printf("\n");
+ if (isNull(ood_new)) break;
+ ood = appendOnto(ood_new,ood);
+ }
+
+ /* Now ood holds the entire set of modules which are out-of-date.
+ Throw them out of the system, yielding a "reduced system",
+ in which the remaining modules are in-date.
+ */
+ for (t = ood; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ nukeModule(mod);
+ }
+ modgList_new = NIL;
+ for (t = modgList; nonNull(t); t=tl(t))
+ if (!varIsMember(textOf(hd(t)),ood))
+ modgList_new = cons(hd(t),modgList_new);
+ modgList = modgList_new;
+
+ /* Update the module group list to reflect the reduced system.
+ We do this so that if the following parsing phases fail, we can
+ safely fall back to the reduced system.
+ */
+ mgFromList ( modgList );
- //numScripts = 0;
+ /* Parse modules/interfaces, collecting parse trees and chasing
+ imports, starting from the target set.
+ */
+ parsedButNotLoaded = NIL;
+ toChase = dupList(targetModules);
+
+ while (nonNull(toChase)) {
+ ConId mc = hd(toChase);
+ toChase = tl(toChase);
+ if (!varIsMember(textOf(mc),modgList)
+ && !varIsMember(textOf(mc),parsedButNotLoaded)) {
+
+ if (setjmp(catch_error)==0) {
+ /* try this; it may throw an exception */
+ mod = parseModuleOrInterface (
+ mc, renewFromSource, renewFromObject );
+ } else {
+ /* here's the exception handler, if parsing fails */
+ /* A parse error (or similar). Clean up and abort. */
+ for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ if (nonNull(mod)) nukeModule(mod);
+ }
+ return;
+ /* end of the exception handler */
+ }
- while (numScripts < namesUpto) {
- ppSmStack ( "readscripts-loop2" );
+ parsedButNotLoaded = cons(mc, parsedButNotLoaded);
+ toChase = dupOnto(module(mod).uses,toChase);
+ }
+ }
- if (scriptInfo[numScripts].fromSource) {
+ modgList = dupOnto(parsedButNotLoaded, modgList);
- if (numScripts>0)
- 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(nextNumScripts<NUM_SCRIPTS);
- }
- }
- }
- if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
- }
+ if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
+ parsedButNotLoaded)) continue;
+
+ if (setjmp(catch_error)==0) {
+ /* try this; it may throw an exception */
+ tryLoadGroup(grp);
+ } else {
+ /* here's the exception handler, if static/typecheck etc fails */
+ badMods = whatIs(grp)==GRP_REC
+ ? snd(grp)
+ : singleton(snd(grp));
+ for (t = badMods; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ if (nonNull(mod)) nukeModule(mod);
+ }
+ mg2 = moduleGraph;
+ while (nonNull(mg2) && nonNull(tl(mg2)) && tl(mg2) != mg)
+ mg2 = tl(mg2);
+ assert(nonNull(mg2) && nonNull(tl(mg2)));
+ tl(mg2) = NIL;
+ return;
+ /* end of the exception handler */
+ }
- didPrelude = processInterfaces();
- if (didPrelude) {
- preludeLoaded = TRUE;
- everybody(POSTPREL);
- }
+ }
+
+ /* Err .. I think that's it. If we get here, we've successfully
+ achieved the target set. Phew!
+ */
+}
- { Int m = namesUpto-1;
- Text mtext = findText(scriptInfo[m].modName);
+static Bool loadThePrelude ( void )
+{
+ Bool ok;
+ ConId conPrelude;
+ ConId conPrelHugs;
+ moduleGraph = prelModules = NIL;
- /* Hack to avoid starting up in PrelHugs */
- if (mtext == findText("PrelHugs")) mtext = findText("Prelude");
+ if (combined) {
+ conPrelude = mkCon(findText("Prelude"));
+ conPrelHugs = mkCon(findText("PrelHugs"));
+ targetModules = doubleton(conPrelude,conPrelHugs);
+ achieveTargetModules();
+ ok = elemMG(conPrelude) && elemMG(conPrelHugs);
+ } else {
+ conPrelude = mkCon(findText("Prelude"));
+ targetModules = singleton(conPrelude);
+ achieveTargetModules();
+ ok = elemMG(conPrelude);
+ }
+ if (ok) prelModules = listFromMG();
+ return ok;
+}
- /* Commented out till we understand what
- * this is trying to do.
- * Problem, you cant find a module till later.
- */
-#if 0
- setCurrModule(findModule(mtext));
-#endif
- evalModule = mtext;
- }
-
+static void refreshActions ( ConId nextCurrMod )
+{
+ ConId tryFor = mkCon(module(currentModule).text);
+ achieveTargetModules();
+ if (nonNull(nextCurrMod))
+ tryFor = nextCurrMod;
+ if (!elemMG(tryFor))
+ tryFor = selectLatestMG();
+ /* combined mode kludge, to get Prelude rather than PrelHugs */
+ if (combined && textOf(tryFor)==findText("PrelHugs"))
+ tryFor = mkCon(findText("Prelude"));
- if (listScripts)
- whatScripts();
- if (numScripts<=1)
- setLastEdit((String)0, 0);
- ppSmStack("readscripts-end ");
+ setCurrModule ( findModule(textOf(tryFor)) );
+ Printf("Hugs session for:\n");
+ ppMG();
}
-static Void local whatScripts() { /* list scripts in current session */
- int i;
- Printf("\nHugs session for:");
- if (projectLoaded)
- Printf(" (project: %s)",currProject);
- for (i=0; i<numScripts; ++i)
- Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
- Putchar('\n');
+
+static void addActions ( List extraModules /* :: [CONID] */ )
+{
+ List t;
+ for (t = extraModules; nonNull(t); t=tl(t)) {
+ ConId extra = hd(t);
+ if (!varIsMember(textOf(extra),targetModules))
+ targetModules = cons(extra,targetModules);
+ }
+ refreshActions ( isNull(extraModules)
+ ? NIL
+ : hd(reverse(extraModules))
+ );
+}
+
+
+static void loadActions ( List loadModules /* :: [CONID] */ )
+{
+ List t;
+ targetModules = dupList ( prelModules );
+
+ for (t = loadModules; nonNull(t); t=tl(t)) {
+ ConId load = hd(t);
+ if (!varIsMember(textOf(load),targetModules))
+ targetModules = cons(load,targetModules);
+ }
+ refreshActions ( isNull(loadModules)
+ ? NIL
+ : hd(reverse(loadModules))
+ );
}
+
/* --------------------------------------------------------------------------
* Access to external editor:
* ------------------------------------------------------------------------*/
+/* ToDo: All this editor stuff needs fixing. */
+
static Void local editor() { /* interpreter-editor interface */
+#if 0
String newFile = readFilename();
if (newFile) {
setLastEdit(newFile,0);
}
}
runEditor();
+#endif
}
static Void local find() { /* edit file containing definition */
#if 0
-This just plain wont work no more.
ToDo: Fix!
String nm = readFilename(); /* of specified name */
if (!nm) {
}
static Void local runEditor() { /* run editor on script lastEdit */
+#if 0
if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
readScripts(N_PRELUDE_SCRIPTS);
+#endif
}
static Void local setLastEdit(fname,line)/* keep name of last file to edit */
String fname;
Int line; {
+#if 0
if (lastEdit)
free(lastEdit);
lastEdit = strCopy(fname);
lastEdLine = line;
-#if HUGS_FOR_WINDOWS
- DrawStatusLine(hWndMain); /* Redo status line */
#endif
}
* Read and evaluate an expression:
* ------------------------------------------------------------------------*/
-static Void local setModule(){/*set module in which to evaluate expressions*/
- String s = readFilename();
- if (!s) s = ""; /* :m clears the current module selection */
- evalModule = findText(s);
- setLastEdit(fileOfModule(findEvalModule()),0);
+static Void setModule ( void ) {
+ /*set module in which to evaluate expressions*/
+ Module m;
+ ConId mc = NIL;
+ String s = readFilename();
+ if (!s) {
+ mc = selectLatestMG();
+ if (combined && textOf(mc)==findText("PrelHugs"))
+ mc = mkCon(findText("Prelude"));
+ m = findModule(textOf(mc));
+ assert(nonNull(m));
+ } else {
+ m = findModule(findText(s));
+ if (isNull(m)) {
+ ERRMSG(0) "Cannot find module \"%s\"", s
+ EEND_NO_LONGJMP;
+ return;
+ }
+ }
+ setCurrModule(m);
}
-static Module local findEvalModule() { /*Module in which to eval expressions*/
- Module m = findModule(evalModule);
- if (isNull(m))
- m = lastModule();
- return m;
+static Module allocEvalModule ( void )
+{
+ Module evalMod = newModule( findText("_Eval_Module_") );
+ module(evalMod).names = module(currentModule).names;
+ module(evalMod).tycons = module(currentModule).tycons;
+ module(evalMod).classes = module(currentModule).classes;
+ return evalMod;
}
static Void local evaluator() { /* evaluate expr and print value */
- Type type, bd;
- Kinds ks = NIL;
-
- setCurrModule(findEvalModule());
+ volatile Type type;
+ volatile Type bd;
+ volatile Kinds ks = NIL;
+ volatile Module evalMod = allocEvalModule();
+ volatile Module currMod = currentModule;
+ setCurrModule(evalMod);
scriptFile = 0;
- startNewScript(0); /* Enables recovery of storage */
- /* allocated during evaluation */
- parseExp();
- checkExp();
+
defaultDefns = combined ? stdDefaults : evalDefaults;
- type = typeCheckExp(TRUE);
+
+ if (setjmp(catch_error)==0) {
+ /* try this */
+ parseExp();
+ checkExp();
+ type = typeCheckExp(TRUE);
+ } else {
+ /* if an exception happens, we arrive here */
+ goto cleanup_and_return;
+ }
if (isPolyType(type)) {
ks = polySigOf(type);
bd = type;
if (whatIs(bd)==QUAL) {
- ERRMSG(0) "Unresolved overloading" ETHEN
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n"
- EEND;
+ ERRMSG(0) "Unresolved overloading" ETHEN
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n"
+ EEND_NO_LONGJMP;
+ goto cleanup_and_return;
}
-#ifdef WANT_TIMER
- updateTimers();
-#endif
-
#if 1
if (isProgType(ks,bd)) {
inputExpr = ap(nameRunIO_toplevel,inputExpr);
} else {
Cell d = provePred(ks,NIL,ap(classShow,bd));
if (isNull(d)) {
- ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
- ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n"
- EEND;
+ ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
+ ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n"
+ EEND_NO_LONGJMP;
+ goto cleanup_and_return;
}
inputExpr = ap2(nameShow, d,inputExpr);
inputExpr = ap (namePutStr, inputExpr);
#endif
+ cleanup_and_return:
+ nukeModule(evalMod);
+ setCurrModule(currMod);
}
-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();
- }
-}
+
/* --------------------------------------------------------------------------
* 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);
}
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;
} else
browseit(findModule(findText(s)),s,all);
if (count == 0) {
- browseit(findEvalModule(),NULL,all);
+ browseit(currentModule,NULL,all);
}
}
{
String s;
Int i;
+#if 0
+ Whats this for?
setCurrModule(findEvalModule());
startNewScript(0);
+#endif
s = readFilename();
/* request to locate a symbol by name */
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(); */
}
}
Int width = getTerminalWidth() - 1;
Int count = 0;
Int termPos;
- Module mod = findEvalModule();
+ Module mod = currentModule;
if (pat) { /* First gather names to list */
do {
}
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));
* 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();
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);
* 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];
return (ap2(nameTangleMessage,str,mkInt(l)));
}
-
Void errHead(l) /* print start of error message */
Int l; {
failed(); /* failed to reach target ... */
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 */
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);
}
sigHandler(breakHandler) { /* respond to break interrupt */
-#if HUGS_FOR_WINDOWS
- MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
-#endif
Hilite();
Printf("{Interrupted!}\n");
Lolite();
* tweaking these functions.
* ------------------------------------------------------------------------*/
-#if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
-
-#ifdef HAVE_STDARG_H
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#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:
* ------------------------------------------------------------------------*/
codegen(what);
}
-/* --------------------------------------------------------------------------
- * Hugs for Windows code (WinMain and related functions)
- * ------------------------------------------------------------------------*/
-
-#if HUGS_FOR_WINDOWS
-#include "winhugs.c"
-#endif
+/*-------------------------------------------------------------------------*/
* 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"
#include <windows.h>
#endif
-#if IS_WIN32 || HUGS_FOR_WINDOWS
+#if IS_WIN32
#undef IN
#endif
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
* - 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<col' and pop indentation off stack,
* `;' in front of token with column==col'.
ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
EEND; /* in the parser... */
}
+
+ if (startWith==SCRIPT) pop(); /* zap spurious closing } token */
final = pop();
+
if (!stackEmpty()) /* stack should now be empty */
internal("parseInput");
return final;
}
-#ifdef HSCRIPT
-static String memPrefix = "@mem@";
-static Int lenMemPrefix = 5; /* strlen(memPrefix)*/
-
-Void makeMemScript(mem,fname)
-String mem;
-String fname; {
- strcat(fname,memPrefix);
- itoa((int)mem, fname+strlen(fname), 10);
-}
-
-Bool isMemScript(fname)
-String fname; {
- return (strstr(fname,memPrefix) != NULL);
-}
-
-String memScriptString(fname)
-String fname; {
- String p = strstr(fname,memPrefix);
- if (p) {
- return (String)atoi(p+lenMemPrefix);
- } else {
- return NULL;
- }
-}
-
-Void parseScript(fname,len) /* Read a script, possibly from mem */
-String fname;
-Long len; {
- input(RESET);
- if (isMemScript(fname)) {
- char* s = memScriptString(fname);
- stringInput(s);
- } else {
- fileInput(fname,len);
- }
- parseInput(SCRIPT);
-}
-#else
-Void parseScript(nm,len) /* Read a script */
-String nm;
-Long len; { /* Used to set a target for reading */
- input(RESET);
- fileInput(nm,len);
- parseInput(SCRIPT);
-}
-#endif
-
Void parseExp() { /* Read an expression to evaluate */
parseInput(EXPR);
setLastExpr(inputExpr);
}
-
#if EXPLAIN_INSTANCE_RESOLUTION
Void parseContext() { /* Read a context to prove */
parseInput(CONTEXT);
String nm;
Long len; { /* Used to set a target for reading */
input(RESET);
+ Printf("Reading interface \"%s\"\n", nm );
fileInput(nm,len);
return parseInput(INTERFACE);
}
+Cell parseModule(nm,len) /* Read a module */
+String nm;
+Long len; { /* Used to set a target for reading */
+ input(RESET);
+ Printf("Reading source file \"%s\"\n", nm );
+ fileInput(nm,len);
+ return parseInput(SCRIPT);
+}
+
/* --------------------------------------------------------------------------
* Input control:
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.39 $
- * $Date: 2000/03/14 14:34:47 $
+ * $Revision: 1.40 $
+ * $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
static Void finishGHCModule ( Cell );
-static Void startGHCModule ( Text, Int, Text );
+static Void startGHCModule ( Text );
static Void startGHCDataDecl ( Int,List,Cell,List,List );
static List finishGHCDataDecl ( ConId tyc );
}
-ZPair readInterface(String fname, Long fileSize)
+List /* of CONID */ getInterfaceImports ( Cell iface )
{
List tops;
List imports = NIL;
- ZPair iface = parseInterface(fname,fileSize);
- assert (whatIs(iface)==I_INTERFACE);
for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
if (whatIs(hd(tops)) == I_IMPORT) {
# endif
}
}
- return zpair(iface,imports);
+ return imports;
}
}
-/* ifaces_outstanding holds a list of parsed interfaces
- for which we need to load objects and create symbol
- table entries.
-
- Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
-*/
-Bool processInterfaces ( void )
+void processInterfaces ( List /* of CONID */ iface_modnames )
{
List tmp;
List xs;
Module mod;
List all_known_types;
Int num_known_types;
- Bool didPrelude;
List cls_list; /* :: List Class */
List constructor_list; /* :: List Name */
List ifaces = NIL; /* :: List I_INTERFACE */
- List iface_sizes = NIL; /* :: List Int */
- List iface_onames = NIL; /* :: List Text */
- if (isNull(ifaces_outstanding)) return FALSE;
+ if (isNull(iface_modnames)) return;
# ifdef DEBUG_IFACE
fprintf ( stderr,
length(ifaces_outstanding) );
# endif
- /* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
- for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
- ifaces = cons ( zfst3(hd(xs)), ifaces );
- iface_onames = cons ( zsnd3(hd(xs)), iface_onames );
- iface_sizes = cons ( zthd3(hd(xs)), iface_sizes );
+ for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
+ mod = findModule(textOf(hd(xs)));
+ assert(nonNull(mod));
+ assert(!module(mod).fromSrc);
+ ifaces = cons ( module(mod).tree, ifaces );
}
-
- ifaces = reverse(ifaces);
- iface_onames = reverse(iface_onames);
- iface_sizes = reverse(iface_sizes);
+ ifaces = reverse(ifaces);
/* Clean up interfaces -- dump non-exported value, class, type decls */
for (xs = ifaces; nonNull(xs); xs = tl(xs))
*/
all_known_types = getAllKnownTyconsAndClasses();
for (xs = ifaces; nonNull(xs); xs=tl(xs))
- all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
+ all_known_types
+ = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
/* Have we reached a fixed point? */
i = length(all_known_types);
/* Allocate module table entries and read in object code. */
- for (xs=ifaces;
- nonNull(xs);
- xs=tl(xs), iface_sizes=tl(iface_sizes), iface_onames=tl(iface_onames)) {
- startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))),
- intOf(hd(iface_sizes)),
- hd(iface_onames) );
- }
- assert (isNull(iface_sizes));
- assert (isNull(iface_onames));
+ for (xs=ifaces; nonNull(xs); xs=tl(xs))
+ startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
/* Now work through the decl lists of the modules, and call the
calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
- didPrelude = FALSE;
cls_list = NIL;
constructor_list = NIL;
for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
setCurrModule(mod);
ppModule ( module(mod).text );
- if (mname == textPrelude) didPrelude = TRUE;
-
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
switch(whatIs(decl)) {
/* Finished! */
ifaces_outstanding = NIL;
-
- return didPrelude;
}
return oc;
}
-static Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+static Void startGHCModule ( Text mname )
{
List xts;
Module m = findModule(mname);
+ assert(nonNull(m));
- if (isNull(m)) {
- m = newModule(mname);
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), sizeObj );
-# endif
- } else {
- if (module(m).fake) {
- module(m).fake = FALSE;
- } else {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
- EEND;
- }
- }
+# ifdef DEBUG_IFACE
+ fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
+ textToStr(mname), module(m).objSize );
+# endif
+ if (module(m).fake)
+ module(m).fake = FALSE;
/* Get hold of the primary object for the module. */
module(m).object
- = startGHCModule_partial_load ( textToStr(nameObj), sizeObj );
+ = startGHCModule_partial_load ( textToStr(module(m).objName),
+ module(m).objSize );
/* and any extras ... */
for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
Int size;
ObjectCode* oc;
Text xtt = hd(xts);
- String nm = getExtraObjectInfo ( textToStr(nameObj),
- textToStr(xtt),
- &size );
+ String nm = getExtraObjectInfo (
+ textToStr(module(m).objName),
+ textToStr(xtt),
+ &size
+ );
if (size == -1) {
ERRMSG(0) "Can't find extra object file \"%s\"", nm
EEND;
* ------------------------------------------------------------------------*/
#define EXTERN_SYMS_ALLPLATFORMS \
+ Sym(MainRegTable) \
Sym(stg_gc_enter_1) \
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
Sym(__sel_10_upd_info) \
Sym(__sel_11_upd_info) \
Sym(__sel_12_upd_info) \
- Sym(MainRegTable) \
Sym(Upd_frame_info) \
Sym(seq_frame_info) \
Sym(CAF_BLACKHOLE_info) \
SymX(rmdir) \
SymX(rename) \
SymX(chdir) \
- Sym(localtime) \
- Sym(strftime) \
SymX(execl) \
Sym(waitpid) \
- Sym(timezone) \
- Sym(mktime) \
- Sym(gmtime) \
SymX(getenv)
#define EXTERN_SYMS_cygwin32 \
SymX(stderr) \
SymX(vfork) \
SymX(_exit) \
- Sym(tzname) \
+ SymX(tzname) \
+ SymX(localtime) \
+ SymX(strftime) \
+ SymX(timezone) \
+ SymX(mktime) \
+ SymX(gmtime) \
* included in the distribution.
*
* $RCSfile: lift.c,v $
- * $Revision: 1.11 $
- * $Date: 2000/03/10 20:03:36 $
+ * $Revision: 1.12 $
+ * $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
StgVar bind = hd(bs);
if (debugSC) {
- if (lastModule() != modulePrelude) {
+ if (currentModule != modulePrelude) {
fprintf(stderr, "\n");
ppStg(hd(bs));
fprintf(stderr, "\n");
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.52 $
- * $Date: 2000/03/15 23:27:16 $
+ * $Revision: 1.53 $
+ * $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
-#include "Assembler.h" /* for asmPrimOps and AsmReps */
-
+#include "Assembler.h" /* for asmPrimOps and AsmReps */
+#include "Rts.h" /* to make Prelude.h palatable */
+#include "Prelude.h" /* for fixupRTStoPreludeRefs */
Type typeArrow; /* Function spaces */
nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
- name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
- name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
- name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
+ if (!combined) {
+ name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
+ name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
+ name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
- /* This is a lie. For a more accurate type of primTakeMVar
- see ghc/interpreter/lib/Prelude.hs.
- */
- name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
+ /* This is a lie. For a more accurate type of primTakeMVar
+ see ghc/interpreter/lib/Prelude.hs.
+ */
+ name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
+ }
if (!combined) {
for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
Name nm;
Module modulePrelBase = findModule(findText("PrelBase"));
assert(nonNull(modulePrelBase));
- fprintf(stderr, "linkControl(POSTPREL)\n");
+ /* fprintf(stderr, "linkControl(POSTPREL)\n"); */
setCurrModule(modulePrelude);
linkPreludeTC();
linkPreludeCM();
Module modulePrelBase;
modulePrelude = findFakeModule(textPrelude);
- module(modulePrelude).objectExtraNames
- = singleton(findText("libHS_cbits"));
- nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",CHAR_REP, STAR );
- nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",INT_REP, STAR );
- nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",WORD_REP, STAR );
- nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",ADDR_REP, STAR );
- nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",FLOAT_REP, STAR );
- nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",DOUBLE_REP, STAR );
+ nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",
+ CHAR_REP, STAR );
+ nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",
+ INT_REP, STAR );
+ nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",
+ WORD_REP, STAR );
+ nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",
+ ADDR_REP, STAR );
+ nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",
+ FLOAT_REP, STAR );
+ nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",
+ DOUBLE_REP, STAR );
nameMkInteger
- = addWiredInBoxingTycon("PrelNum","Integer","Integer#",0 ,STAR );
+ = addWiredInBoxingTycon("PrelNum","Integer","Integer#",
+ 0 ,STAR );
nameMkPrimByteArray
- = addWiredInBoxingTycon("PrelGHC","ByteArray","PrimByteArray#",0 ,STAR );
+ = addWiredInBoxingTycon("PrelGHC","ByteArray",
+ "PrimByteArray#",0 ,STAR );
for (i=0; i<NUM_TUPLES; ++i) {
if (i != 1) addTupleTycon(i);
}
addWiredInEnumTycon("PrelBase","Bool",
- doubleton(findText("False"),findText("True")));
+ doubleton(findText("False"),
+ findText("True")));
//nameMkThreadId
- // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
- // ,1,0,THREADID_REP);
+ // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
+ // ,1,0,THREADID_REP);
setCurrModule(modulePrelude);
nameId.
*/
modulePrelBase = findModule(findText("PrelBase"));
+ module(modulePrelBase).objectExtraNames
+ = singleton(findText("libHS_cbits"));
+
setCurrModule(modulePrelBase);
pFun(nameId, "id");
setCurrModule(modulePrelude);
} else {
fixupRTStoPreludeRefs(NULL);
- modulePrelude = newModule(textPrelude);
+ modulePrelude = //newModule(textPrelude);
+ findFakeModule(textPrelude);
setCurrModule(modulePrelude);
for (i=0; i<NUM_TUPLES; ++i) {
* included in the distribution.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.21 $
- * $Date: 2000/03/20 04:26:23 $
+ * $Revision: 1.22 $
+ * $Date: 2000/03/22 18:14:22 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
#ifdef HAVE_DOS_H
# include <dos.h>
#endif
-#if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS
+#if defined HAVE_CONIO_H
# include <conio.h>
#endif
#ifdef HAVE_IO_H
# include <windows.h>
#endif
-#if HUGS_FOR_WINDOWS
-#include <dir.h>
-#include <mem.h>
-
-extern HCURSOR HandCursor; /* Forward references to cursors */
-extern HCURSOR GarbageCursor;
-extern HCURSOR SaveCursor;
-static void local DrawStatusLine ( HWND );
-#endif
-
#if DOS
#include <mem.h>
extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
* 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 * );
}
-/* If the primaryObjectName for is (eg)
+/* If the primaryObjectName is (eg)
/foo/bar/PrelSwamp.o
and the extraFileName is (eg)
swampy_cbits
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();
Printf("%d}}",recovered);
FlushStdout();
}
-#if HUGS_FOR_WINDOWS
- SetCursor(SaveCursor);
-#endif
}
Cell *CStackBase; /* Retain start of C control stack */
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
case RESET :
case BREAK :
case EXIT : normalTerminal();
-#if HUGS_FOR_WINDOWS
- if (what==EXIT)
- DestroyWindow(hWndMain);
- else
- SetCursor(LoadCursor(NULL,IDC_ARROW));
-#endif
break;
}
}
* 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)))))
#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
#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)
%}
%%
/*- 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");}
;
;
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));}
/*- Top-level misc interface stuff ------------------------*/
ifOrphans : '!' {$$=gc1(NIL);}
| {$$=gc0(NIL);}
+ifIsBoot : '@' {$$=gc1(NIL);}
+ | {$$=gc0(NIL);}
;
ifOptCOCO : COCO {$$=gc1(NIL);}
| {$$=gc0(NIL);}
/*- 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);}
;
/*- 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);}
/*- 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));}
/*- 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);}
/*- 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");}
/*- 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()) {
* 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
#include <windows.h> /* 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:
#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:
*-------------------------------------------------------------------------*/
#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
/*---------------------------------------------------------------------------
* 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
#define FPrintf fprintf
#define Putc putc
-#endif
-
/*-------------------------------------------------------------------------*/
* 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
}
#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 */
#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 */
* 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"
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 );
* 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);
}
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:;
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);
}
}
}
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;
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)
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;
}
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 {
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);
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.
}
#endif
-Void checkDefns() { /* Top level static analysis */
- Module thisModule = lastModule();
+Void checkDefns ( Module thisModule ) { /* Top level static analysis */
+
staticAnalysis(RESET);
setCurrModule(thisModule);
/* 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);
/* 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 */
* 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"
* 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 );
/* --------------------------------------------------------------------------
#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<NUM_TEXT) /* standard char string */
- return text + t;
- if (t<0)
- sprintf(newVar,"d%d",-t); /* dictionary variable */
- else
- sprintf(newVar,"v%d",t-NUM_TEXT); /* normal variable */
- return newVar;
+ if (isText(t)) /* standard char string */
+ return text + t - TEXT_BASE_ADDR;
+ if (isInventedDictVar(t)) {
+ sprintf(newVar,"d%d",
+ t-INDVAR_BASE_ADDR); /* dictionary variable */
+ return newVar;
+ }
+ if (isInventedVar(t)) {
+ sprintf(newVar,"v%d",
+ t-INVAR_BASE_ADDR); /* normal variable */
+ return newVar;
+ }
+ internal("textToStr");
}
String identToStr(v) /*find string corresp to given ident or qualified name*/
}
Text inventText() { /* return new unused variable name */
- return nextNewText++;
+ if (nextNewText >= 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
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
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;
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);
}
#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:
*
* ------------------------------------------------------------------------*/
#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<TYCONHSZ);
+ return r;
+}
+static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */
+int RC_T ( int x )
+{
+ assert (x >= 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;
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);
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 */
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<tyconHw; ++tc)
- if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
- if (nonNull(tycon(tc).kind))
- ts = insertTycon(tc,ts);
+ for (tc = TYCON_BASE_ADDR;
+ tc < TYCON_BASE_ADDR+tabTyconSz; ++tc)
+ if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
+ if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
+ if (nonNull(tycon(tc).kind))
+ ts = insertTycon(tc,ts);
return ts;
}
Int i;
if (n >= 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");
}
* ------------------------------------------------------------------------*/
#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;
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);
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*/
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;
}
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)");
}
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
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<nameHw; ++nm) /* or invented names are excluded) */
- if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
- String str = textToStr(name(nm).text);
- if (str[0]!='_' && (!pat || stringMatch(pat,str)))
- ns = insertName(nm,ns);
- }
+ for (nm = NAME_BASE_ADDR;
+ nm < NAME_BASE_ADDR+tabNameSz; ++nm)
+ if (tabName[nm-NAME_BASE_ADDR].inUse) {
+ if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
+ String str = textToStr(name(nm).text);
+ if (str[0]!='_' && (!pat || stringMatch(pat,str)))
+ ns = insertName(nm,ns);
+ }
+ }
return ns;
#else
List mns = module(currentModule).names;
* Storage of type classes, instances etc...:
* ------------------------------------------------------------------------*/
-static Class classHw; /* next unused class */
static List classes; /* list of classes in current scope */
-static Inst instHw; /* next unused instance record */
-
-struct strClass DEFTABLE(tabClass,NUM_CLASSES); /* table of class records */
-struct strInst far *tabInst; /* (pointer to) table of instances */
-Class newClass(t) /* add new class to class table */
-Text t; {
- if (classHw-CLASSMIN >= 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; {
}
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
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;
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 )
{
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 )
{
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;
}
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);
}
/* --------------------------------------------------------------------------
* 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<UPPER_DISP; i++) {
- ERRTEXT "\nwhile evaluating: " ETHEN
- ERREXPR(evalRoots[rootsp-i]);
- }
- ERRTEXT "\n..." ETHEN
- for (i=LOWER_DISP-1; 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:
*
* ------------------------------------------------------------------------*/
-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 )
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);
}
Module findModule(t) /* locate Module in module table */
Text t; {
Module m;
- for(m=MODMIN; m<moduleHw; ++m) {
- if (module(m).text==t)
- return m;
+ for(m = MODULE_BASE_ADDR;
+ m < MODULE_BASE_ADDR+tabModuleSz; ++m) {
+ if (tabModule[m-MODULE_BASE_ADDR].inUse)
+ if (module(m).text==t)
+ return m;
}
return NIL;
}
Module findModid(c) /* Find module by name or filename */
Cell c; {
switch (whatIs(c)) {
- case STRCELL : { Script s = scriptThisFile(snd(c));
- return (s==-1) ? NIL : moduleOfScript(s);
- }
+ case STRCELL : internal("findModid-STRCELL unimp");
case CONIDCELL : return findModule(textOf(c));
default : internal("findModid");
}
if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
}
-#if 1 /* mpj */
if (module(currentModule).text==t)
return currentModule;
-#endif
return NIL;
}
Module m; {
Int i;
assert(isModule(m));
- if (m!=currentModule) {
- currentModule = m; /* This is the only assignment to currentModule */
- for (i=0; i<TYCONHSZ; ++i)
- tyconHash[i] = NIL;
- mapProc(hashTycon,module(m).tycons);
- for (i=0; i<NAMEHSZ; ++i)
- nameHash[i] = NIL;
- mapProc(hashName,module(m).names);
- classes = module(m).classes;
- }
+fprintf(stderr, "SET CURR MODULE %s\n", textToStr(module(m).text));
+ {List t;
+ for (t = module(m).names; nonNull(t); t=tl(t))
+ assert(isName(hd(t)));
+ for (t = module(m).tycons; nonNull(t); t=tl(t))
+ assert(isTycon(hd(t)) || isTuple(hd(t)));
+ for (t = module(m).classes; nonNull(t); t=tl(t))
+ assert(isClass(hd(t)));
+ }
+
+ currentModule = m; /* This is the only assignment to currentModule */
+ for (i=0; i<TYCONHSZ; ++i)
+ tyconHash[RC_T(i)] = NIL;
+ mapProc(hashTycon,module(m).tycons);
+ for (i=0; i<NAMEHSZ; ++i)
+ nameHash[RC_N(i)] = NIL;
+ mapProc(hashName,module(m).names);
+ classes = module(m).classes;
+ hashSanity();
}
Name jrsFindQualName ( Text mn, Text sn )
Module m;
List ns;
- for (m=MODMIN; m<moduleHw; m++)
- if (module(m).text == mn) break;
- if (m == moduleHw) return NIL;
+ for (m = MODULE_BASE_ADDR;
+ m < MODULE_BASE_ADDR+tabModuleSz; m++)
+ if (tabModule[m-MODULE_BASE_ADDR].inUse
+ && module(m).text == mn) break;
+
+ if (m == MODULE_BASE_ADDR+tabModuleSz) return NIL;
for (ns = module(m).names; nonNull(ns); ns=tl(ns))
if (name(hd(ns)).text == sn) return hd(ns);
{
int i;
Module m;
- for (m=MODMIN; m<moduleHw; m++) {
- if (module(m).object) {
+ for (m = MODULE_BASE_ADDR;
+ m < MODULE_BASE_ADDR+tabModuleSz; m++) {
+ if (tabModule[m-MODULE_BASE_ADDR].inUse && module(m).object) {
char* nm = ocLookupAddr ( module(m).object, p );
if (nm) return nm;
}
void* lookupOTabName ( Module m, char* sym )
{
+ assert(isModule(m));
if (module(m).object)
return ocLookupSym ( module(m).object, sym );
return NULL;
{
ObjectCode* oc;
Module m;
- for (m = MODMIN; m < moduleHw; m++) {
- for (oc = module(m).objectExtras; oc; oc=oc->next) {
- 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;
}
ObjectCode* oc;
OSectionKind sect;
- for (m=MODMIN; m<moduleHw; m++) {
- 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;
+ 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;
/* --------------------------------------------------------------------------
- * 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 : "<nofile>" );
- 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<scriptHw \
- && x>=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<scriptHw; ++s) {
- if (scripts[s].moduleHw == m) {
- return textToStr(scripts[s].file);
- }
- }
- return 0;
-}
-
-Script scriptThisFile(f)
-Text f; {
- Script s;
- for (s=0; s < scriptHw; ++s) {
- if (scripts[s].file == f) {
- return s+1;
- }
- }
- if (f == findText(STD_PRELUDE)) {
- return 0;
- }
- return (-1);
-}
-
-Void dropScriptsFrom(sno) /* Restore storage to state prior */
-Script sno; { /* to reading script sno */
- if (sno<scriptHw) { /* is there anything to restore? */
- int i;
- textHw = scripts[sno].textHw;
- nextNewText = scripts[sno].nextNewText;
- nextNewDText = scripts[sno].nextNewDText;
- moduleHw = scripts[sno].moduleHw;
- tyconHw = scripts[sno].tyconHw;
- nameHw = scripts[sno].nameHw;
- classHw = scripts[sno].classHw;
- instHw = scripts[sno].instHw;
-#if USE_DICTHW
- dictHw = scripts[sno].dictHw;
-#endif
-#if TREX
- extHw = scripts[sno].extHw;
-#endif
-
-#if 0
- for (i=moduleHw; i >= 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<TEXTHSZ; ++i) {
- int j = 0;
- while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
- && textHash[i][j]<textHw)
- ++j;
- if (j<NUM_TEXTH)
- textHash[i][j] = NOTEXT;
- }
-
- currentModule=NIL;
- for (i=0; i<TYCONHSZ; ++i) {
- tyconHash[i] = NIL;
- }
- for (i=0; i<NAMEHSZ; ++i) {
- nameHash[i] = NIL;
- }
-
- for (i=CLASSMIN; i<classHw; i++) {
- List ins = cclass(i).instances;
- List is = NIL;
-
- while (nonNull(ins)) {
- List temp = tl(ins);
- if (hd(ins)<instHw) {
- tl(ins) = is;
- is = ins;
- }
- ins = temp;
- }
- cclass(i).instances = rev(is);
- }
-
- scriptHw = sno;
- }
-}
-
-/* --------------------------------------------------------------------------
* Heap storage:
*
* Provides a garbage collectable heap for storage of expressions etc.
return c;
}
-Void overwrite(dst,src) /* overwrite dst cell with src cell*/
-Cell dst, src; { /* both *MUST* be pairs */
- if (isPair(dst) && isPair(src)) {
- fst(dst) = fst(src);
- snd(dst) = snd(src);
- }
- else
- internal("overwrite");
-}
-
static Int *marks;
static Int marksSize;
fst(c) = markCell(fst(c));
markSnd(c);
}
- else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
+ else if (isNull(fst(c)) || isTagPtr(fst(c))) {
STACK_CHECK
markSnd(c);
}
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;
}
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();
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 :
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 :
* 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)) {
else return TUPLE;
#endif
+
/* if (isPair(c)) {
register Cell fstc = fst(c);
return isTag(fstc) ? fstc : AP;
if (c>=TUPMIN) return TUPLE;
return c;*/
}
+#endif
+
/* A very, very simple printer.
* Output is uglier than from printExp - but the printer is more
{
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:
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));
}
Printf(")");
break;
- case NIL:
- Printf("NIL");
- break;
case WILDCARD:
Printf("_");
break;
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;
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);
}
/* --------------------------------------------------------------------------
- * Strongly-typed lists (z-lists) and tuples (experimental)
+ * Tagged tuples (experimental)
* ------------------------------------------------------------------------*/
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 )
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;
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;
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;
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;
* 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;
lsave = NIL;
rsave = NIL;
if (isNull(lastExprSaved))
- savedText = NUM_TEXT;
+ savedText = TEXT_SIZE;
break;
case MARK :
start();
- for (i=NAMEMIN; i<nameHw; ++i) {
- mark(name(i).parent);
- mark(name(i).defn);
- mark(name(i).stgVar);
- mark(name(i).type);
- }
+ for (i = NAME_BASE_ADDR;
+ i < NAME_BASE_ADDR+tabNameSz; ++i) {
+ if (tabName[i-NAME_BASE_ADDR].inUse) {
+ mark(name(i).parent);
+ mark(name(i).defn);
+ mark(name(i).stgVar);
+ mark(name(i).type);
+ }
+ }
end("Names", nameHw-NAMEMIN);
start();
- for (i=MODMIN; i<moduleHw; ++i) {
- mark(module(i).tycons);
- mark(module(i).names);
- mark(module(i).classes);
- mark(module(i).exports);
- mark(module(i).qualImports);
- mark(module(i).objectExtraNames);
+ for (i = MODULE_BASE_ADDR;
+ i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
+ if (tabModule[i-MODULE_BASE_ADDR].inUse) {
+ mark(module(i).tycons);
+ mark(module(i).names);
+ mark(module(i).classes);
+ mark(module(i).exports);
+ mark(module(i).qualImports);
+ mark(module(i).objectExtraNames);
+ }
}
+ mark(moduleGraph);
+ mark(prelModules);
+ mark(targetModules);
end("Modules", moduleHw-MODMIN);
start();
- for (i=TYCMIN; i<tyconHw; ++i) {
- mark(tycon(i).defn);
- mark(tycon(i).kind);
- mark(tycon(i).what);
+ for (i = TYCON_BASE_ADDR;
+ i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
+ if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
+ mark(tycon(i).defn);
+ mark(tycon(i).kind);
+ mark(tycon(i).what);
+ }
}
end("Type constructors", tyconHw-TYCMIN);
start();
- for (i=CLASSMIN; i<classHw; ++i) {
- mark(cclass(i).head);
- mark(cclass(i).kinds);
- mark(cclass(i).fds);
- mark(cclass(i).xfds);
- mark(cclass(i).dsels);
- mark(cclass(i).supers);
- mark(cclass(i).members);
- mark(cclass(i).defaults);
- mark(cclass(i).instances);
+ for (i = CCLASS_BASE_ADDR;
+ i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
+ if (tabModule[i-MODULE_BASE_ADDR].inUse) {
+ mark(cclass(i).head);
+ mark(cclass(i).kinds);
+ mark(cclass(i).fds);
+ mark(cclass(i).xfds);
+ mark(cclass(i).dsels);
+ mark(cclass(i).supers);
+ mark(cclass(i).members);
+ mark(cclass(i).defaults);
+ mark(cclass(i).instances);
+ }
}
mark(classes);
end("Classes", classHw-CLASSMIN);
start();
- for (i=INSTMIN; i<instHw; ++i) {
- mark(inst(i).head);
- mark(inst(i).kinds);
- mark(inst(i).specifics);
- mark(inst(i).implements);
+ for (i = INST_BASE_ADDR;
+ i < INST_BASE_ADDR+tabInstSz; ++i) {
+ if (tabInst[i-INST_BASE_ADDR].inUse) {
+ mark(inst(i).head);
+ mark(inst(i).kinds);
+ mark(inst(i).specifics);
+ mark(inst(i).implements);
+ }
}
end("Instances", instHw-INSTMIN);
EEND;
}
- TABALLOC(text, char, NUM_TEXT)
- TABALLOC(tyconHash, Tycon, TYCONHSZ)
- TABALLOC(tabTycon, struct strTycon, NUM_TYCON)
- TABALLOC(nameHash, Name, NAMEHSZ)
- TABALLOC(tabName, struct strName, NUM_NAME)
- TABALLOC(tabClass, struct strClass, NUM_CLASSES)
- TABALLOC(cellStack, Cell, NUM_STACK)
- TABALLOC(tabModule, struct Module, NUM_SCRIPTS)
-#if TREX
- TABALLOC(tabExt, Text, NUM_EXT)
-#endif
clearStack();
textHw = 0;
- nextNewText = NUM_TEXT;
- nextNewDText = (-1);
+ nextNewText = INVAR_BASE_ADDR;
+ nextNewDText = INDVAR_BASE_ADDR;
lastExprSaved = NIL;
- savedText = NUM_TEXT;
- for (i=0; i<TEXTHSZ; ++i)
- textHash[i][0] = NOTEXT;
-
-
- moduleHw = MODMIN;
-
- tyconHw = TYCMIN;
- for (i=0; i<TYCONHSZ; ++i)
- tyconHash[i] = NIL;
-#if TREX
- extHw = EXTMIN;
-#endif
-
- nameHw = NAMEMIN;
- for (i=0; i<NAMEHSZ; ++i)
- nameHash[i] = NIL;
-
- classHw = CLASSMIN;
-
- instHw = INSTMIN;
-
-#if USE_DICTHW
- dictHw = 0;
-#endif
-
- tabInst = (struct strInst far *)
- farCalloc(NUM_INSTS,sizeof(struct strInst));
-
- if (tabInst==0) {
- ERRMSG(0) "Cannot allocate instance tables"
- EEND;
- }
+ savedText = TEXT_SIZE;
- scriptHw = 0;
+ for (i=0; i<TEXTHSZ; ++i) textHash[i][0] = NOTEXT;
+ for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
+ for (i=0; i<NAMEHSZ; ++i) nameHash[RC_N(i)] = NIL;
break;
}
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.34 $
- * $Date: 2000/03/13 11:37:17 $
+ * $Revision: 1.35 $
+ * $Date: 2000/03/22 18:14:23 $
* ------------------------------------------------------------------------*/
+#define DEBUG_STORAGE
+
/* --------------------------------------------------------------------------
* Typedefs for main data types:
* Many of these type names are used to indicate the intended us of a data
typedef Cell Pair; /* pair cell */
typedef Int StackPtr; /* stack pointer */
typedef Cell Offset; /* offset/generic variable*/
-typedef Int Script; /* script file number */
typedef Int Module; /* module */
typedef Cell Tycon; /* type constructor */
typedef Cell Type; /* type expression */
typedef Cell ConVarId;
/* --------------------------------------------------------------------------
+ * Address ranges.
+ *
+ * -heapSize .. -1 cells in the heap
+ * 0 NIL
+ *
+ * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(115) non pointer tags
+ * TAG_PTR_MIN(200) .. TAG_PTR_MAX(298) pointer tags
+ * TAG_SPEC_MIN(400) .. TAG_SPEC_MAX(425) special tags
+ * OFF_MIN(1,000) .. OFF_MAX(1,999) offsets
+ * CHAR_MIN(3,000) .. CHAR_MAX(3,255) chars
+ *
+ * SMALL_INT_MIN(100,000) .. SMALL_INT_MAX(499,999) smallish ints
+ * (300,000 denotes 0)
+ *
+ * NAME_BASE_ADDR (1,000,000 .. 1,899,999) names
+ * TYCON_BASE_ADDR (2,000,000 .. 2,899,999) tycons
+ * CCLASS_BASE_ADDR (3,000,000 .. 3,899,999) classes
+ * INST_BASE_ADDR (4,000,000 .. 4,899,999) instances
+ * MODULE_BASE_ADDR (5,000,000 .. 5,899,999) modules
+ * INVAR_BASE_ADDR (6,000,000 .. 6,899,999) invented var names
+ * INDVAR_BASE_ADDR (7,000,000 .. 7,899,999) invented dict var names
+ * TEXT_BASE_ADDR (8,000,000 .. 8M +TEXT_SIZE-1) text
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
* Text storage:
* provides storage for the characters making up identifier and symbol
* names, string literals, character constants etc...
extern Syntax identSyntax ( Cell );
extern Syntax defaultSyntax ( Text );
+#define INVAR_BASE_ADDR 6000000
+#define INVAR_MAX_AVAIL 900000
+#define isInventedVar(c) (INVAR_BASE_ADDR<=(c) \
+ && (c)<INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
+
+#define INDVAR_BASE_ADDR 7000000
+#define INDVAR_MAX_AVAIL 900000
+#define isInventedDictVar(c) (INDVAR_BASE_ADDR<=(c) \
+ && (c)<INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
+
+#define TEXT_BASE_ADDR 8000000
+#define isText(c) (TEXT_BASE_ADDR<=(c) \
+ && (c)<TEXT_BASE_ADDR+TEXT_SIZE)
+
/* --------------------------------------------------------------------------
* Specification of syntax (i.e. default written form of application)
* ------------------------------------------------------------------------*/
extern Heap heapTopSnd;
extern Bool consGC; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
-extern Int cellsRecovered; /* cells recovered by last gc */
+extern Int cellsRecovered; /* cells recovered by last gc */
#define fst(c) heapTopFst[c]
#define snd(c) heapTopSnd[c]
extern Void garbageCollect ( Void );
extern Void overwrite ( Pair,Pair );
-extern Void overwrite2 ( Pair,Cell,Cell );
extern Cell markExpr ( Cell );
extern Void markWithoutMove ( Cell );
extern Cell whatIs ( Cell );
/* --------------------------------------------------------------------------
- * Box cell tags are used as the fst element of a pair to indicate that
- * the snd element of the pair is to be treated in some special way, other
- * than as a Cell. Examples include holding integer values, variable name
- * and string text etc.
+ * Pairs in the heap fall into three categories.
+ *
+ * pair(TAG_NONPTR,y)
+ * used to denote that the second element of the pair is to be treated
+ * in some special way (eg is a integer or Text), and specifically is not
+ * a heap pointer
+ *
+ * pair(TAG_PTR,y)
+ * to indicate that the second element of the pair is a normal
+ * heap pointer, which should be followed at GC time
+ *
+ * pair(x,y)
+ * is a genuine pair, where both components are heap pointers.
* ------------------------------------------------------------------------*/
#if !defined(SIZEOF_VOID_P) || !defined(SIZEOF_INT)
#error SIZEOF_VOID_P or SIZEOF_INT is not defined
#endif
-#define TAGMIN 1 /* Box and constructor cell tag values */
-#define BCSTAG 30 /* Box=TAGMIN..BCSTAG-1 */
-#define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
-#define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
-#define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
-
-#define FREECELL 3 /* Free list cell: snd :: Cell */
-#define VARIDCELL 4 /* Identifier variable: snd :: Text */
-#define VAROPCELL 5 /* Operator variable: snd :: Text */
-#define DICTVAR 6 /* Dictionary variable: snd :: Text */
-#define CONIDCELL 7 /* Identifier constructor: snd :: Text */
-#define CONOPCELL 8 /* Operator constructor: snd :: Text */
-#define STRCELL 9 /* String literal: snd :: Text */
-#define INTCELL 10 /* Int literal: snd :: Int */
-#define ADDPAT 11 /* (_+k) pattern discr: snd :: Int */
-#define FLOATCELL 15 /* Floating Pt literal: snd :: Text */
-#define BIGCELL 16 /* Integer literal: snd :: Text */
-#define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
-#define CPTRCELL 21 /* Native code pointer snd :: Ptr */
+#define isTagNonPtr(c) (TAG_NONPTR_MIN<=(c) && (c)<=TAG_NONPTR_MAX)
+#define isTagPtr(c) (TAG_PTR_MIN<=(c) && (c)<=TAG_PTR_MAX)
+#define isTag(c) (isTagNonPtr(c) || isTagPtr(c))
+
+/* --------------------------------------------------------------------------
+ * Tags for non-pointer cells.
+ * ------------------------------------------------------------------------*/
+
+#define TAG_NONPTR_MIN 100
+#define TAG_NONPTR_MAX 115
+
+#define FREECELL 100 /* Free list cell: snd :: Cell */
+#define VARIDCELL 101 /* Identifier variable: snd :: Text */
+#define VAROPCELL 102 /* Operator variable: snd :: Text */
+#define DICTVAR 103 /* Dictionary variable: snd :: Text */
+#define CONIDCELL 104 /* Identifier constructor: snd :: Text */
+#define CONOPCELL 105 /* Operator constructor: snd :: Text */
+#define STRCELL 106 /* String literal: snd :: Text */
+#define INTCELL 107 /* Int literal: snd :: Int */
+#define ADDPAT 108 /* (_+k) pattern discr: snd :: Int */
+#define FLOATCELL 109 /* Floating Pt literal: snd :: Text */
+#define BIGCELL 110 /* Integer literal: snd :: Text */
+#define PTRCELL 111 /* C Heap Pointer snd :: Ptr */
+#define CPTRCELL 112 /* Native code pointer snd :: Ptr */
#if IPARAM
-#define IPCELL 19 /* Imp Param Cell: snd :: Text */
-#define IPVAR 20 /* ?x: snd :: Text */
+#define IPCELL 113 /* Imp Param Cell: snd :: Text */
+#define IPVAR 114 /* ?x: snd :: Text */
#endif
#if TREX
-#define EXTCOPY 22 /* Copy of an Ext: snd :: Text */
+#define EXTCOPY 115 /* Copy of an Ext: snd :: Text */
#endif
#define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
extern Bool isQVar ( Cell );
extern Bool isQCon ( Cell );
extern Bool isQualIdent ( Cell );
-extern Bool eqQualIdent ( QualId c1, QualId c2 );
+extern Bool eqQualIdent ( QualId c1, QualId c2 );
extern Bool isIdent ( Cell );
extern String stringNegate ( String );
extern Text textOf ( Cell );
extern Ptr cptrOf ( Cell );
/* --------------------------------------------------------------------------
- * Constructor cell tags are used as the fst element of a pair to indicate
- * a particular syntactic construct described by the snd element of the
- * pair.
- * Note that a cell c will not be treated as an application (AP/isAp) node
- * if its first element is a constructor cell tag, whereas a cell whose fst
- * element is a special cell will be treated as an application node.
+ * Tags for pointer cells.
* ------------------------------------------------------------------------*/
-#define LETREC 30 /* LETREC snd :: ([Decl],Exp) */
-#define COND 31 /* COND snd :: (Exp,Exp,Exp) */
-#define LAMBDA 32 /* LAMBDA snd :: Alt */
-#define FINLIST 33 /* FINLIST snd :: [Exp] */
-#define DOCOMP 34 /* DOCOMP snd :: (Exp,[Qual]) */
-#define BANG 35 /* BANG snd :: Type */
-#define COMP 36 /* COMP snd :: (Exp,[Qual]) */
-#define ASPAT 37 /* ASPAT snd :: (Var,Exp) */
-#define ESIGN 38 /* ESIGN snd :: (Exp,Type) */
-#define RSIGN 39 /* RSIGN snd :: (Rhs,Type) */
-#define CASE 40 /* CASE snd :: (Exp,[Alt]) */
-#define NUMCASE 41 /* NUMCASE snd :: (Exp,Disc,Rhs) */
-#define FATBAR 42 /* FATBAR snd :: (Exp,Exp) */
-#define LAZYPAT 43 /* LAZYPAT snd :: Exp */
-#define DERIVE 45 /* DERIVE snd :: Cell */
-#define BOOLQUAL 49 /* BOOLQUAL snd :: Exp */
-#define QWHERE 50 /* QWHERE snd :: [Decl] */
-#define FROMQUAL 51 /* FROMQUAL snd :: (Exp,Exp) */
-#define DOQUAL 52 /* DOQUAL snd :: Exp */
-#define MONADCOMP 53 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
-#define GUARDED 54 /* GUARDED snd :: [guarded exprs] */
-#define ARRAY 55 /* Array snd :: (Bounds,[Values]) */
-#define MUTVAR 56 /* Mutvar snd :: Cell */
-#define HUGSOBJECT 57 /* HUGSOBJECT snd :: Cell */
+#define TAG_PTR_MIN 200
+#define TAG_PTR_MAX 298
+
+#define LETREC 200 /* LETREC snd :: ([Decl],Exp) */
+#define COND 201 /* COND snd :: (Exp,Exp,Exp) */
+#define LAMBDA 202 /* LAMBDA snd :: Alt */
+#define FINLIST 203 /* FINLIST snd :: [Exp] */
+#define DOCOMP 204 /* DOCOMP snd :: (Exp,[Qual]) */
+#define BANG 205 /* BANG snd :: Type */
+#define COMP 206 /* COMP snd :: (Exp,[Qual]) */
+#define ASPAT 207 /* ASPAT snd :: (Var,Exp) */
+#define ESIGN 208 /* ESIGN snd :: (Exp,Type) */
+#define RSIGN 209 /* RSIGN snd :: (Rhs,Type) */
+#define CASE 210 /* CASE snd :: (Exp,[Alt]) */
+#define NUMCASE 211 /* NUMCASE snd :: (Exp,Disc,Rhs) */
+#define FATBAR 212 /* FATBAR snd :: (Exp,Exp) */
+#define LAZYPAT 213 /* LAZYPAT snd :: Exp */
+#define DERIVE 214 /* DERIVE snd :: Cell */
+#define BOOLQUAL 215 /* BOOLQUAL snd :: Exp */
+#define QWHERE 216 /* QWHERE snd :: [Decl] */
+#define FROMQUAL 217 /* FROMQUAL snd :: (Exp,Exp) */
+#define DOQUAL 218 /* DOQUAL snd :: Exp */
+#define MONADCOMP 219 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
+#define GUARDED 220 /* GUARDED snd :: [guarded exprs] */
+#define ARRAY 221 /* Array snd :: (Bounds,[Values]) */
+#define MUTVAR 222 /* Mutvar snd :: Cell */
+#define HUGSOBJECT 223 /* HUGSOBJECT snd :: Cell */
#if IPARAM
-#define WITHEXP 58 /* WITHEXP snd :: [(Var,Exp)] */
+#define WITHEXP 224 /* WITHEXP snd :: [(Var,Exp)] */
#endif
-#define POLYTYPE 60 /* POLYTYPE snd :: (Kind,Type) */
-#define QUAL 61 /* QUAL snd :: ([Classes],Type) */
-#define RANK2 62 /* RANK2 snd :: (Int,Type) */
-#define EXIST 63 /* EXIST snd :: (Int,Type) */
-#define POLYREC 64 /* POLYREC snd :: (Int,Type) */
-#define BIGLAM 65 /* BIGLAM snd :: (vars,patterns) */
-#define CDICTS 66 /* CDICTS snd :: ([Pred],Type) */
-
-#define LABC 67 /* LABC snd :: (con,[(Vars,Type)]) */
-#define CONFLDS 68 /* CONFLDS snd :: (con,[Field]) */
-#define UPDFLDS 69 /* UPDFLDS snd :: (Exp,[con],[Field]) */
+#define POLYTYPE 225 /* POLYTYPE snd :: (Kind,Type) */
+#define QUAL 226 /* QUAL snd :: ([Classes],Type) */
+#define RANK2 227 /* RANK2 snd :: (Int,Type) */
+#define EXIST 228 /* EXIST snd :: (Int,Type) */
+#define POLYREC 229 /* POLYREC snd :: (Int,Type) */
+#define BIGLAM 230 /* BIGLAM snd :: (vars,patterns) */
+#define CDICTS 231 /* CDICTS snd :: ([Pred],Type) */
+
+#define LABC 232 /* LABC snd :: (con,[(Vars,Type)]) */
+#define CONFLDS 233 /* CONFLDS snd :: (con,[Field]) */
+#define UPDFLDS 234 /* UPDFLDS snd :: (Exp,[con],[Field]) */
#if TREX
-#define RECORD 70 /* RECORD snd :: [Val] */
-#define EXTCASE 71 /* EXTCASE snd :: (Exp,Disc,Rhs) */
-#define RECSEL 72 /* RECSEL snd :: Ext */
+#define RECORD 235 /* RECORD snd :: [Val] */
+#define EXTCASE 236 /* EXTCASE snd :: (Exp,Disc,Rhs) */
+#define RECSEL 237 /* RECSEL snd :: Ext */
#endif
-#define IMPDEPS 73 /* IMPDEPS snd :: [Binding] */
+#define IMPDEPS 238 /* IMPDEPS snd :: [Binding] */
-#define QUALIDENT 74 /* Qualified identifier snd :: (Id,Id) */
-#define HIDDEN 75 /* hiding import list snd :: [Entity] */
-#define MODULEENT 76 /* module in export list snd :: con */
+#define QUALIDENT 239 /* Qualified identifier snd :: (Id,Id) */
+#define HIDDEN 240 /* hiding import list snd :: [Entity] */
+#define MODULEENT 241 /* module in export list snd :: con */
-#define INFIX 77 /* INFIX snd :: (see tidyInfix) */
-#define ONLY 78 /* ONLY snd :: Exp */
-#define NEG 79 /* NEG snd :: Exp */
+#define INFIX 242 /* INFIX snd :: (see tidyInfix) */
+#define ONLY 243 /* ONLY snd :: Exp */
+#define NEG 244 /* NEG snd :: Exp */
/* Used when parsing GHC interface files */
-#define DICTAP 80 /* DICTAP snd :: (QClassId,[Type]) */
-#define UNBOXEDTUP 81 /* UNBOXEDTUP snd :: [Type] */
+#define DICTAP 245 /* DICTAP snd :: (QClassId,[Type]) */
+#define UNBOXEDTUP 246 /* UNBOXEDTUP snd :: [Type] */
#if SIZEOF_VOID_P != SIZEOF_INT
-#define PTRCELL 82 /* C Heap Pointer snd :: (Int,Int) */
+#define PTRCELL 247 /* C Heap Pointer snd :: (Int,Int) */
#endif
/* STG syntax */
-#define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
-#define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */
-#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
-#define STGCON 95 /* STGCON snd :: (StgCon,[Arg]) */
-#define PRIMCASE 96 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
-#define DEEFALT 97 /* DEEFALT snd :: (Var,Expr) */
-#define CASEALT 98 /* CASEALT snd :: (Con,[Var],Expr) */
-#define PRIMALT 99 /* PRIMALT snd :: ([Var],Expr) */
+#define STGVAR 248 /* STGVAR snd :: (StgRhs,info) */
+#define STGAPP 249 /* STGAPP snd :: (StgVar,[Arg]) */
+#define STGPRIM 250 /* STGPRIM snd :: (PrimOp,[Arg]) */
+#define STGCON 251 /* STGCON snd :: (StgCon,[Arg]) */
+#define PRIMCASE 252 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
+#define DEEFALT 253 /* DEEFALT snd :: (Var,Expr) */
+#define CASEALT 254 /* CASEALT snd :: (Con,[Var],Expr) */
+#define PRIMALT 255 /* PRIMALT snd :: ([Var],Expr) */
+
+/* Module groups */
+#define GRP_REC 256 /* GRP_REC snd :: [CONID] */
+#define GRP_NONREC 257 /* GRP_NONREC snd :: CONID */
/*
Top-level interface entities
type Line = Int -- a line number
type ConVarId = CONIDCELL | VARIDCELL
- type <a> = ZList a
- type ExportListEntry = ConVarId | (ConId, <ConVarId>)
+ type ExportListEntry = ConVarId | (ConId, [ConVarId])
type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
type Constr = ((ConId, [((Type,VarId,Int))]))
((constr name, [((type, field name if any, strictness))]))
z-tuples.
*/
-#define I_INTERFACE 109 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
+#define I_INTERFACE 260 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
interface name, list of iface entities */
-#define I_IMPORT 110 /* snd :: ((ConId, [ConVarId]))
+#define I_IMPORT 261 /* snd :: ((ConId, [ConVarId]))
module name, list of entities */
-#define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */
+#define I_INSTIMPORT 262 /* snd :: NIL -- not used at present */
-#define I_EXPORT 112 /* snd :: ((ConId, [ExportListEntry]))
+#define I_EXPORT 263 /* snd :: ((ConId, [ExportListEntry]))
this module name?, entities to export */
-#define I_FIXDECL 113 /* snd :: ((NIL|Int, Associativity, ConVarId))
+#define I_FIXDECL 264 /* snd :: ((NIL|Int, Associativity, ConVarId))
fixity, associativity, name */
-#define I_INSTANCE 114 /* snd :: ((Line,
+#define I_INSTANCE 265 /* snd :: ((Line,
[((VarId,Kind))],
Type, VarId, Inst))
lineno,
name of dictionary builder,
(after startGHCInstance) the instance table location */
-#define I_TYPE 115 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
+#define I_TYPE 266 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
lineno, tycon, kinded tyvars, the type expr */
-#define I_DATA 116 /* snd :: ((Line, [((QConId,VarId))], ConId,
+#define I_DATA 267 /* snd :: ((Line, [((QConId,VarId))], ConId,
[((VarId,Kind))], [Constr])
lineno, context, tycon, kinded tyvars, constrs
An empty constr list means exported abstractly. */
-#define I_NEWTYPE 117 /* snd :: ((Line, [((QConId,VarId))], ConId,
+#define I_NEWTYPE 268 /* snd :: ((Line, [((QConId,VarId))], ConId,
[((VarId,Kind))], ((ConId,Type)) ))
lineno, context, tycon, kinded tyvars, constr
constr==NIL means exported abstractly. */
-#define I_CLASS 118 /* snd :: ((Line, [((QConId,VarId))], ConId,
+#define I_CLASS 269 /* snd :: ((Line, [((QConId,VarId))], ConId,
[((VarId,Kind))], [((VarId,Type))]))
lineno, context, classname,
kinded tyvars, method sigs */
-#define I_VALUE 119 /* snd :: ((Line, VarId, Type)) */
+#define I_VALUE 270 /* snd :: ((Line, VarId, Type)) */
+
+/*
+ Top-level module entities.
+
+ type Export = ?
+*/
+#define M_MODULE 280 /* snd :: ((ConId, [Export],
+ M_IMPORT_Q .. M_VALUE]))
+ module name, export spec, top level entities */
+
+#define M_IMPORT_Q 281 /* snd :: ((?,?)) */
+#define M_IMPORT_UNQ 282 /* snd :: ((?,?)) */
+#define M_TYCON 283 /* snd :: ((Line,?,?,?)) */
+#define M_CLASS 284 /* snd :: ((Line,?,?,?)) */
+#define M_INST 285 /* snd :: ((Line,?,?)) */
+#define M_DEFAULT 286 /* snd :: ((Line,?)) */
+#define M_FOREIGN_EX 289 /* snd :: ((Line,?,?,?,?)) */
+#define M_FOREIGN_IM 290 /* snd :: ((Line,?,?,?,?)) */
+#define M_VALUE 291 /* snd :: ? */
-/* Generic syntax */
-#if 0
-#define ZCONS 190 /* snd :: (Cell,Cell) */
-#endif
+/*
+ Tagged tuples.
+*/
+#define ZTUP2 295 /* snd :: (Cell,Cell) */
+#define ZTUP3 296 /* snd :: (Cell,(Cell,Cell)) */
+#define ZTUP4 297 /* snd :: (Cell,(Cell,(Cell,Cell))) */
+#define ZTUP5 298 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
-#define ZTUP2 192 /* snd :: (Cell,Cell) */
-#define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */
-#define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */
-#define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
-/* Last constructor tag must be less than SPECMIN */
/* --------------------------------------------------------------------------
- * Special cell values:
+ * Special cell values.
* ------------------------------------------------------------------------*/
-#define SPECMIN 201
+#define TAG_SPEC_MIN 400
+#define TAG_SPEC_MAX 428
-#if TREX
-#define isSpec(c) (SPECMIN<=(c) && (c)<EXTMIN)/* Special cell values */
-#else
-#define isSpec(c) (SPECMIN<=(c) && (c)<OFFMIN)
-#endif
+#define isSpec(c) (TAG_SPEC_MIN<=(c) && (c)<=TAG_SPEC_MAX)
-#define NONE 201 /* Dummy stub */
-#define STAR 202 /* Representing the kind of types */
+#define NONE 400 /* Dummy stub */
+#define STAR 401 /* Representing the kind of types */
#if TREX
-#define ROW 203 /* Representing the kind of rows */
+#define ROW 402 /* Representing the kind of rows */
#endif
-#define WILDCARD 204 /* Wildcard pattern */
-#define SKOLEM 205 /* Skolem constant */
-
-#define DOTDOT 206 /* ".." in import/export list */
-
-#define NAME 210 /* whatIs code for isName */
-#define TYCON 211 /* whatIs code for isTycon */
-#define CLASS 212 /* whatIs code for isClass */
-#define MODULE 213 /* whatIs code for isModule */
-#define INSTANCE 214 /* whatIs code for isInst */
-#define TUPLE 215 /* whatIs code for tuple constructor */
-#define OFFSET 216 /* whatis code for offset */
-#define AP 217 /* whatIs code for application node */
-#define CHARCELL 218 /* whatIs code for isChar */
+#define WILDCARD 403 /* Wildcard pattern */
+#define SKOLEM 404 /* Skolem constant */
+
+#define DOTDOT 405 /* ".." in import/export list */
+
+#define NAME 406 /* whatIs code for isName */
+#define TYCON 407 /* whatIs code for isTycon */
+#define CLASS 408 /* whatIs code for isClass */
+#define MODULE 409 /* whatIs code for isModule */
+#define INSTANCE 410 /* whatIs code for isInst */
+#define TUPLE 411 /* whatIs code for tuple constructor */
+#define OFFSET 412 /* whatis code for offset */
+#define AP 413 /* whatIs code for application node */
+#define CHARCELL 414 /* whatIs code for isChar */
#if TREX
-#define EXT 219 /* whatIs code for isExt */
+#define EXT 415 /* whatIs code for isExt */
#endif
-#define SIGDECL 220 /* Signature declaration */
-#define FIXDECL 221 /* Fixity declaration */
-#define FUNBIND 222 /* Function binding */
-#define PATBIND 223 /* Pattern binding */
+#define SIGDECL 416 /* Signature declaration */
+#define FIXDECL 417 /* Fixity declaration */
+#define FUNBIND 418 /* Function binding */
+#define PATBIND 419 /* Pattern binding */
+
+#define DATATYPE 420 /* Datatype type constructor */
+#define NEWTYPE 421 /* Newtype type constructor */
+#define SYNONYM 422 /* Synonym type constructor */
+#define RESTRICTSYN 423 /* Synonym with restricted scope */
-#define DATATYPE 230 /* Datatype type constructor */
-#define NEWTYPE 231 /* Newtype type constructor */
-#define SYNONYM 232 /* Synonym type constructor */
-#define RESTRICTSYN 233 /* Synonym with restricted scope */
+#define NODEPENDS 424 /* Stop calculation of deps in type check*/
+#define PREDEFINED 425 /* Predefined name, not yet filled */
+#define TEXTCELL 426 /* whatIs code for isText */
+#define INVAR 427 /* whatIs code for isInventedVar */
+#define INDVAR 428 /* whatIs code for isInventedDictVar */
-#define NODEPENDS 235 /* Stop calculation of deps in type check*/
-#define PREDEFINED 236 /* Predefined name, not yet filled */
/* --------------------------------------------------------------------------
* Tuple data/type constructors:
#if TREX
+#error TREX not supported
#define EXTMIN 301
#define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
#define extText(e) tabExt[(e)-EXTMIN]
#define mkExt(t) NIL
#endif
-extern Module findFakeModule ( Text t );
-extern Tycon addTupleTycon ( Int n );
-extern Name addWiredInBoxingTycon
- ( String modNm, String typeNm, String constrNm,
- Int rep, Kind kind );
-Tycon addWiredInEnumTycon ( String modNm, String typeNm,
- List /*of Text*/ constrs );
+extern Module findFakeModule ( Text t );
+extern Tycon addTupleTycon ( Int n );
+extern Name addWiredInBoxingTycon
+ ( String modNm, String typeNm, String constrNm,
+ Int rep, Kind kind );
+extern Tycon addWiredInEnumTycon
+ ( String modNm, String typeNm,
+ List /*of Text*/ constrs );
/* --------------------------------------------------------------------------
* Offsets: (generic types/stack offsets)
* ------------------------------------------------------------------------*/
-#if TREX
-#define OFFMIN (EXTMIN+NUM_EXT)
-#else
-#define OFFMIN 301
-#endif
-#define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
-#define offsetOf(c) ((c)-OFFMIN)
-#define mkOffset(o) (OFFMIN+(o))
+#define OFF_MIN 1000
+#define OFF_MAX 1999
+
+#define isOffset(c) (OFF_MIN<=(c) && (c)<=OFF_MAX)
+#define offsetOf(c) ((c)-OFF_MIN)
+#define mkOffset(o) (OFF_MIN+(o))
/* --------------------------------------------------------------------------
* Modules:
* ------------------------------------------------------------------------*/
-#define MODMIN (OFFMIN+NUM_OFFSETS)
+#define MODULE_BASE_ADDR 5000000
+#define MODULE_MAX_SIZE 900000
+#define MODULE_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strModule* generate_module_ref ( Cell );
+#define module(mod) (*generate_module_ref(mod))
+#else
+#define module(mod) tabModule[(mod)-MODULE_BASE_ADDR]
+#endif
+
+#define mkModule(n) (MODULE_BASE_ADDR+(n))
+#define isModule(c) (MODULE_BASE_ADDR<=(c) \
+ && (c)<MODULE_BASE_ADDR+tabModuleSz \
+ && tabModule[(c)-MODULE_BASE_ADDR].inUse)
-#define isModule(c) (MODMIN<=(c) && (c)<TYCMIN)
-#define mkModule(n) (MODMIN+(n))
-#define module(n) tabModule[(n)-MODMIN]
/* Import defns for the ObjectCode struct in Module. */
#include "object.h"
+/* Import a machine-dependent definition of Time, for module timestamps. */
+#include "machdep_time.h"
+
/* Under Haskell 1.3, the list of qualified imports is always a subset
* of the list of unqualified imports. For simplicity and flexibility,
* we do not attempt to exploit this fact - when a module is imported
* list is just a flat list of Texts (before static analysis) or
* Tycons, Names and Classes (after static analysis).
*/
-struct Module {
- Text text;
- /* Lists of top level objects (local defns + imports) */
- List tycons;
- List names;
- List classes;
- List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
- /* List of qualified imports. Used both during compilation and when
- * evaluating an expression in the context of the current module.
- */
- List qualImports;
-
- /* TRUE if module exists only via GHC primop defn; usually FALSE */
- Bool fake;
-
- /* The primary object file for this module. */
- ObjectCode* object;
-
- /* And any extras it might need. */
- ObjectCode* objectExtras;
- List objectExtraNames; /* :: [Text] -- names of extras */
+struct strModule {
+ Bool inUse;
+ Name nextFree;
+
+ Text text; /* Name of this module */
+
+ List tycons; /* Lists of top level objects ... */
+ List names; /* (local defns + imports) */
+ List classes;
+ List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
+
+ List qualImports; /* Qualified imports. */
+
+ Bool fake; /* TRUE if module exists only via GHC primop */
+ /* defn; usually FALSE */
+
+ Cell tree; /* Parse tree for mod or iface */
+ Bool completed; /* Fully loaded or just parsed? */
+ Time lastStamp; /* Time of last parse */
+
+ Bool fromSrc; /* is it from source ? */
+ Text srcExt; /* if yes, ".lhs", ".hs", etc" */
+ List uses; /* :: [CONID] -- names of mods imported by this one */
+
+ Text objName; /* Name of the primary object code file. */
+ Int objSize; /* Size of the primary object code file. */
+
+ ObjectCode* object; /* Primary object code for this module. */
+ ObjectCode* objectExtras; /* And any extras it might need. */
+ List objectExtraNames; /* :: [Text] -- names of extras */
};
+extern struct strModule* tabModule;
+extern Int tabModuleSz;
extern Module currentModule; /* Module currently being processed */
-extern struct Module DECTABLE(tabModule);
+extern List moduleGraph; /* :: [GRP_REC | GRP_NONREC] */
+extern List prelModules; /* :: [CONID] */
+extern List targetModules; /* :: [CONID] */
+
-extern Bool isValidModule ( Module );
-extern Module newModule ( Text );
-extern Module findModule ( Text );
-extern Module findModid ( Cell );
-extern Void setCurrModule ( Module );
+extern Bool isValidModule ( Module );
+extern Module newModule ( Text );
+extern Void nukeModule ( Module );
+extern Module findModule ( Text );
+extern Module findModid ( Cell );
+extern Void setCurrModule ( Module );
-extern void addOTabName ( Module,char*,void* );
-extern void* lookupOTabName ( Module,char* );
-extern char* nameFromOPtr ( void* );
+extern void addOTabName ( Module,char*,void* );
+extern void* lookupOTabName ( Module,char* );
+extern char* nameFromOPtr ( void* );
-extern void addSection ( Module,void*,void*,OSectionKind );
-extern OSectionKind lookupSection ( void* );
-extern void* lookupOExtraTabName ( char* sym );
+extern void addSection ( Module,void*,void*,OSectionKind );
+extern OSectionKind lookupSection ( void* );
+extern void* lookupOExtraTabName ( char* sym );
#define isPrelude(m) (m==modulePrelude)
* Type constructor names:
* ------------------------------------------------------------------------*/
-#define TYCMIN (MODMIN+NUM_MODULE)
-#define isTycon(c) (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple==-1)
-#define tycon(n) tabTycon[(n)-TYCMIN]
+#define TYCON_BASE_ADDR 2000000
+#define TYCON_MAX_SIZE 900000
+#define TYCON_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strTycon* generate_tycon_ref ( Cell );
+#define tycon(tc) (*generate_tycon_ref(tc))
+#else
+#define tycon(tc) tabTycon[(tc)-TYCON_BASE_ADDR]
+#endif
+
+#define isTycon(c) (TYCON_BASE_ADDR<=(c) \
+ && (c)<TYCON_BASE_ADDR+tabTyconSz \
+ && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
+ && tabTycon[(c)-TYCON_BASE_ADDR].tuple==-1)
+#define isTuple(c) (TYCON_BASE_ADDR<=(c) \
+ && (c)<TYCON_BASE_ADDR+tabTyconSz \
+ && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
+ && tabTycon[(c)-TYCON_BASE_ADDR].tuple>=0)
+#define tupleOf(n) (tycon(n).tuple)
-#define isTuple(c) (TYCMIN<=(c) && (c)<NAMEMIN && tabTycon[(c)-TYCMIN].tuple>=0)
-#define tupleOf(n) (tabTycon[(n)-TYCMIN].tuple)
extern Tycon mkTuple ( Int );
struct strTycon {
+ Bool inUse;
+ Name nextFree;
Text text;
Int line;
Module mod; /* module that defines it */
Tycon nextTyconHash;
};
-extern struct strTycon DECTABLE(tabTycon);
+extern struct strTycon* tabTycon;
+extern Int tabTyconSz;
extern Tycon newTycon ( Text );
extern Tycon findTycon ( Text );
#define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
#define polySigOf(t) fst(snd(t))
#define monotypeOf(t) snd(snd(t))
-
#define bang(t) ap(BANG,t)
+
extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Globally defined name values:
* ------------------------------------------------------------------------*/
-#define NAMEMIN (TYCMIN+NUM_TYCON)
-#define isName(c) (NAMEMIN<=(c) && (c)<INSTMIN)
-#define mkName(n) (NAMEMIN+(n))
-#define name(n) tabName[(n)-NAMEMIN]
+#define NAME_BASE_ADDR 1000000
+#define NAME_MAX_SIZE 900000
+#define NAME_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strName* generate_name_ref ( Cell );
+#define name(nm) (*generate_name_ref(nm))
+#else
+#define name(nm) tabName[(nm)-NAME_BASE_ADDR]
+#endif
+
+#define mkName(n) (NAME_BASE_ADDR+(n))
+#define isName(c) (NAME_BASE_ADDR<=(c) \
+ && (c)<NAME_BASE_ADDR+tabNameSz \
+ && tabName[(c)-NAME_BASE_ADDR].inUse)
struct strName {
+ Bool inUse;
+ Name nextFree;
Text text;
Int line;
Module mod; /* module that defines it */
Name nextNameHash;
};
-extern int numNames ( Void );
+extern struct strName* tabName;
+extern Int tabNameSz;
-extern struct strName DECTABLE(tabName);
+extern int numNames ( Void );
/* The number field in a name is used to distinguish various kinds of name:
* mfunNo(i) = code for member function, offset i
* Type class values:
* ------------------------------------------------------------------------*/
-#define INSTMIN (NAMEMIN+NUM_NAME) /* instances */
-#define isInst(c) (INSTMIN<=(c) && (c)<CLASSMIN)
-#define mkInst(n) (INSTMIN+(n))
-#define instOf(c) ((Int)((c)-INSTMIN))
-#define inst(in) tabInst[(in)-INSTMIN]
+#define INST_BASE_ADDR 4000000
+#define INST_MAX_SIZE 900000
+#define INST_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strInst* generate_inst_ref ( Cell );
+#define inst(in) (*generate_inst_ref(in))
+#else
+#define inst(in) tabInst[(in)-INST_BASE_ADDR]
+#endif
+
+#define mkInst(n) (INST_BASE_ADDR+(n))
+#define instOf(c) ((Int)((c)-INST_BASE_ADDR))
+#define isInst(c) (INST_BASE_ADDR<=(c) \
+ && (c)<INST_BASE_ADDR+tabInstSz \
+ && tabInst[(c)-INST_BASE_ADDR].inUse)
struct strInst {
+ Bool inUse;
+ Name nextFree;
Class c; /* class C */
Int line;
Module mod; /* module that defines it */
Name builder; /* Dictionary constructor function */
};
+extern struct strInst* tabInst;
+extern Int tabInstSz;
+
/* a predicate (an element :: Pred) is an application of a Class to one or
* more type expressions
*/
-#define CLASSMIN (INSTMIN+NUM_INSTS)
-#define isClass(c) (CLASSMIN<=(c) && (c)<CHARMIN)
-#define mkClass(n) (CLASSMIN+(n))
-#define cclass(n) tabClass[(n)-CLASSMIN]
+#define CCLASS_BASE_ADDR 3000000
+#define CCLASS_MAX_SIZE 900000
+#define CCLASS_INIT_SIZE 4
+
+#ifdef DEBUG_STORAGE
+extern struct strClass* generate_cclass_ref ( Cell );
+#define cclass(cl) (*generate_cclass_ref(cl))
+#else
+#define cclass(cl) tabClass[(cl)-CCLASS_BASE_ADDR]
+#endif
+
+#define mkClass(n) (CCLASS_BASE_ADDR+(n))
+#define isClass(c) (CCLASS_BASE_ADDR<=(c) \
+ && (c)<CCLASS_BASE_ADDR+tabClassSz \
+ && tabClass[(c)-CCLASS_BASE_ADDR].inUse)
struct strClass {
+ Bool inUse;
+ Name nextFree;
Text text; /* Name of class */
Int line; /* Line where declaration begins */
Module mod; /* module that declares it */
List instances; /* :: [Inst] */
};
-extern struct strClass DECTABLE(tabClass);
-extern struct strInst far *tabInst;
+extern struct strClass* tabClass;
+extern Int tabClassSz;
extern Class newClass ( Text );
-extern Class classMax ( Void );
extern Class findClass ( Text );
extern Class addClass ( Class );
extern Class findQualClass ( Cell );
extern Inst newInst ( Void );
extern Inst findFirstInst ( Tycon );
extern Inst findNextInst ( Tycon,Inst );
-extern List getAllKnownTyconsAndClasses ( void );
+extern List getAllKnownTyconsAndClasses ( void );
extern Class findQualClassWithoutConsultingExportList ( QualId q );
/* --------------------------------------------------------------------------
* Character values:
* ------------------------------------------------------------------------*/
-#define CHARMIN (CLASSMIN+NUM_CLASSES)
+/* I think this assumes that NUM_CHARS==256. */
+#define CHAR_MIN 3000
+#define CHAR_MAX 3255
+#define isChar(c) (CHAR_MIN<=(c) && (c)<=CHAR_MAX)
+#define charOf(c) ((Char)((c)-CHAR_MIN))
+#define mkChar(c) (CHAR_MIN+(((Cell)(c)) & 0xFF))
#define MAXCHARVAL (NUM_CHARS-1)
-#define isChar(c) (CHARMIN<=(c) && (c)<INTMIN)
-#define charOf(c) ((Char)(c-CHARMIN))
-#define mkChar(c) ((Cell)(CHARMIN+(((unsigned)(c))%NUM_CHARS)))
/* --------------------------------------------------------------------------
* Small Integer values:
* ------------------------------------------------------------------------*/
-#define INTMIN (CHARMIN+NUM_CHARS)
-#define INTMAX (MAXPOSINT)
-#define isSmall(c) (INTMIN<=(c))
-#define INTZERO (INTMIN/2 + INTMAX/2)
-#define MINSMALLINT (INTMIN - INTZERO)
-#define MAXSMALLINT (INTMAX - INTZERO)
-#define mkDigit(c) ((Cell)((c)+INTMIN))
-#define digitOf(c) ((Int)((c)-INTMIN))
-
-extern Bool isInt ( Cell );
-extern Int intOf ( Cell );
-extern Cell mkInt ( Int );
+#define SMALL_INT_MIN 100000
+#define SMALL_INT_MAX 499999
+#define SMALL_INT_ZERO (1 + SMALL_INT_MIN/2 + SMALL_INT_MAX/2)
+#define isSmall(c) (SMALL_INT_MIN<=(c) && (c)<=SMALL_INT_MAX)
+extern Bool isInt ( Cell );
+extern Int intOf ( Cell );
+extern Cell mkInt ( Int );
/* --------------------------------------------------------------------------
* Implementation of triples:
* Implementation of lists:
* ------------------------------------------------------------------------*/
-#define NIL 0
-#define isNull(c) ((c)==NIL)
-#define nonNull(c) (c)
-#define cons(x,xs) pair(x,xs)
+#define NIL 0
+#define isNull(c) ((c)==NIL)
+#define nonNull(c) (c)
+#define cons(x,xs) pair(x,xs)
#define singleton(x) cons(x,NIL)
#define doubleton(x,y) cons(x,cons(y,NIL))
#define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
-#define hd(c) fst(c)
-#define tl(c) snd(c)
+#define hd(c) fst(c)
+#define tl(c) snd(c)
extern Int length ( List );
extern List appendOnto ( List,List ); /* destructive */
extern List dupOnto ( List,List );
extern List dupList ( List );
extern List revOnto ( List, List ); /* destructive */
-#define rev(xs) revOnto((xs),NIL) /* destructive */
-#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
+#define rev(xs) revOnto((xs),NIL) /* destructive */
+#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
extern Cell cellIsMember ( Cell,List );
extern Cell cellAssoc ( Cell,List );
extern Cell cellRevAssoc ( Cell,List );
typedef Cell Z4Ble;
typedef Cell Z5Ble;
-#if 0
-typedef Cell ZList;
-extern Cell zcons ( Cell x, Cell xs );
-extern Cell zhd ( Cell xs );
-extern Cell ztl ( Cell xs );
-extern Cell zsingleton ( Cell x );
-extern Cell zdoubleton ( Cell x, Cell y );
-extern Int zlength ( ZList xs );
-extern ZList zreverse ( ZList xs );
-#endif
-
-extern Cell zpair ( Cell x1, Cell x2 );
-extern Cell zfst ( Cell zpair );
-extern Cell zsnd ( Cell zpair );
-
-extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
-extern Cell zfst3 ( Cell zpair );
-extern Cell zsnd3 ( Cell zpair );
-extern Cell zthd3 ( Cell zpair );
-
-extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
-extern Cell zsel14 ( Cell zpair );
-extern Cell zsel24 ( Cell zpair );
-extern Cell zsel34 ( Cell zpair );
-extern Cell zsel44 ( Cell zpair );
-
-extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
-extern Cell zsel15 ( Cell zpair );
-extern Cell zsel25 ( Cell zpair );
-extern Cell zsel35 ( Cell zpair );
-extern Cell zsel45 ( Cell zpair );
-extern Cell zsel55 ( Cell zpair );
-
-extern Cell unap ( int tag, Cell c );
#define isZPair(c) (whatIs((c))==ZTUP2)
+extern Cell zpair ( Cell x1, Cell x2 );
+extern Cell zfst ( Cell zpair );
+extern Cell zsnd ( Cell zpair );
+
+extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
+extern Cell zfst3 ( Cell zpair );
+extern Cell zsnd3 ( Cell zpair );
+extern Cell zthd3 ( Cell zpair );
+
+extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
+extern Cell zsel14 ( Cell zpair );
+extern Cell zsel24 ( Cell zpair );
+extern Cell zsel34 ( Cell zpair );
+extern Cell zsel44 ( Cell zpair );
+
+extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
+extern Cell zsel15 ( Cell zpair );
+extern Cell zsel25 ( Cell zpair );
+extern Cell zsel35 ( Cell zpair );
+extern Cell zsel45 ( Cell zpair );
+extern Cell zsel55 ( Cell zpair );
+
+extern Cell unap ( int tag, Cell c );
+
+
/* --------------------------------------------------------------------------
* Implementation of function application nodes:
* ------------------------------------------------------------------------*/
#define fun(c) fst(c)
#define arg(c) snd(c)
#define isAp(c) (isPair(c) && !isTag(fst(c)))
+
extern Cell getHead ( Cell );
extern List getArgs ( Cell );
-extern Int argCount;
extern Cell nthArg ( Int,Cell );
extern Int numArgs ( Cell );
extern Cell applyToArgs ( Cell,List );
+extern Int argCount;
/* --------------------------------------------------------------------------
* Stack implementation:
* For example, "push(1+pop());" doesn't increment TOS.
* ------------------------------------------------------------------------*/
-extern Cell DECTABLE(cellStack);
+extern Cell cellStack[];
extern StackPtr sp;
#define clearStack() sp=(-1)
#define stackEmpty() (sp==(-1))
#define stack(p) cellStack[p]
#define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
-#define push(c) \
- do { \
- chkStack(1); \
- onto(c); \
- } while (0)
+#define push(c) do { chkStack(1); onto(c); } while (0)
#define onto(c) stack(++sp)=(c);
#define pop() stack(sp--)
#define drop() sp--
#endif
/* --------------------------------------------------------------------------
- * Script file control:
- * The implementation of script file storage is hidden.
- * ------------------------------------------------------------------------*/
-
-extern Script startNewScript ( String );
-extern Bool moduleThisScript ( Module );
-extern Module moduleOfScript ( Script );
-extern Bool isPreludeScript ( Void );
-extern Module lastModule ( Void );
-extern Script scriptThisFile ( Text );
-extern Script scriptThisName ( Name );
-extern Script scriptThisTycon ( Tycon );
-extern Script scriptThisInst ( Inst );
-extern Script scriptThisClass ( Class );
-extern String fileOfModule ( Module );
-extern Void dropScriptsFrom ( Script );
-
-
-/* --------------------------------------------------------------------------
* Misc:
* ------------------------------------------------------------------------*/
-extern Void setLastExpr ( Cell );
-extern Cell getLastExpr ( Void );
-extern List addTyconsMatching ( String,List );
-extern List addNamesMatching ( String,List );
+extern Void setLastExpr ( Cell );
+extern Cell getLastExpr ( Void );
+extern List addTyconsMatching ( String,List );
+extern List addNamesMatching ( String,List );
-extern Tycon findTyconInAnyModule ( Text t );
-extern Class findClassInAnyModule ( Text t );
-extern Name findNameInAnyModule ( Text t );
+extern Tycon findTyconInAnyModule ( Text t );
+extern Class findClassInAnyModule ( Text t );
+extern Name findNameInAnyModule ( Text t );
extern Void print ( Cell, Int );
extern void dumpTycon ( Int t );
* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.15 $
- * $Date: 2000/03/13 14:11:14 $
+ * $Revision: 1.16 $
+ * $Date: 2000/03/22 18:14:23 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Int maxTyvars = 0;
static Int nextGeneric; /* number of generics found so far */
-#if FIXED_SUBST
-Tyvar tyvars[NUM_TYVARS]; /* storage for type variables */
-#else
Tyvar *tyvars = 0; /* storage for type variables */
-#endif
Int typeOff; /* offset of result type */
Type typeIs; /* skeleton of result type */
Int typeFree; /* freedom in instantiated type */
Void emptySubstitution() { /* clear current substitution */
numTyvars = 0;
-#if !FIXED_SUBST
if (maxTyvars!=NUM_TYVARS) {
maxTyvars = 0;
if (tyvars) {
tyvars = 0;
}
}
-#endif
nextGeneric = 0;
genericVars = NIL;
typeIs = NIL;
static Void local expandSubst(n) /* add further n type variables to */
Int n; { /* current substituion */
-#if FIXED_SUBST
- if (numTyvars+n>NUM_TYVARS) {
- ERRMSG(0) "Too many type variables in type checker"
- EEND;
- }
-#else
if (numTyvars+n>maxTyvars) { /* need to expand substitution */
Int newMax = maxTyvars+NUM_TYVARS;
Tyvar *newTvs;
tyvars = newTvs;
maxTyvars = newMax;
}
-#endif
}
Int newTyvars(n) /* allocate new type variables */
case FIXED_TYVAR : return mkInt(vn);
case UNUSED_GENERIC : (tyv->offs) = GENERIC + nextGeneric++;
- if (nextGeneric>=NUM_OFFSETS) {
+ if (nextGeneric>=(OFF_MAX-OFF_MIN+1)) {
ERRMSG(0)
"Too many quantified type variables"
EEND;
projects / ghc-hetmet.git / commitdiff