diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile
index 45b574be188329cc592782c9ead44750964a600f..0a410a9b31e2497c2551e9694420ccf4c01e13b9 100644
--- a/ghc/interpreter/Makefile
+++ b/ghc/interpreter/Makefile
@@ -1,6 +1,6 @@
# ----------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.8 1999/04/27 10:59:29 sewardj Exp $ #
+# $Id: Makefile,v 1.9 1999/06/07 17:22:54 sewardj Exp $ #
# ----------------------------------------------------------------------------- #
TOP = ../..
@@ -17,6 +17,7 @@ YACC = bison -y
%.c: %.y
-$(YACC) $<
mv y.tab.c $@
+ rm -f input.o
HS_SRCS =
@@ -24,9 +25,9 @@ HS_SRCS =
Y_SRCS = parser.y
C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \
- hugs.c dynamic.c stg.c sainteger.c
+ hugs.c dynamic.c stg.c sainteger.c interface.c
-SRC_CC_OPTS = -O2 -g -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused
+SRC_CC_OPTS = -g -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused
GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a
@@ -49,7 +50,7 @@ cleanish:
snapshot:
/bin/rm -f snapshot.tar
- tar cvf snapshot.tar Makefile *.[chy] *-ORIG-* \
+ tar cvf snapshot.tar Makefile *.[chy] \
../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \
../rts/ForeignCall.c ../rts/Printer.c ../rts/QueueTemplate.h \
../includes/options.h ../includes/Assembler.h nHandle.c \
diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index ca9b482d3d3c6cf4960cf53479ff1b31183e90f3..32d1ebf55f867aaa8e7e6e8a0926e7a349de02f0 100644
--- a/ghc/interpreter/codegen.c
+++ b/ghc/interpreter/codegen.c
@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:06:48 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:53 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -106,15 +106,21 @@ static void cgBind( AsmBCO bco, StgVar v )
static Void pushVar( AsmBCO bco, StgVar v )
{
- Cell info = stgVarInfo(v);
+ Cell info;
assert(isStgVar(v));
- if (isPtr(info)) {
- asmClosure(bco,ptrOf(info));
- } else if (isInt(info)) {
- asmVar(bco,intOf(info),repOf(v));
+
+ if (isCPtr(v)) {
+fprintf ( stderr, "push cptr %p\n", (void*)cptrOf(v) );
} else {
- internal("pushVar");
- }
+ info = stgVarInfo(v);
+ if (isPtr(info)) {
+ asmClosure(bco,ptrOf(info));
+ } else if (isInt(info)) {
+ asmVar(bco,intOf(info),repOf(v));
+ } else {
+ internal("pushVar");
+ }
+ }
}
static Void pushAtom( AsmBCO bco, StgAtom e )
@@ -154,6 +160,9 @@ static Void pushAtom( AsmBCO bco, StgAtom e )
asmClosure(bco,asmStringObj(textToStr(textOf(e))));
#endif
break;
+ case CPTRCELL:
+ asmConstWord(bco,cptrOf(e));
+ break;
case PTRCELL:
asmConstAddr(bco,ptrOf(e));
break;
@@ -483,9 +492,13 @@ static Void build( AsmBCO bco, StgVar v )
if (isName(fun)) {
fun = name(fun).stgVar;
}
- if (nonNull(stgVarBody(fun))
- && whatIs(stgVarBody(fun)) == LAMBDA
- && length(stgLambdaArgs(stgVarBody(fun))) > length(args)) {
+ if (isCPtr(fun)
+ ||
+ (nonNull(stgVarBody(fun))
+ && whatIs(stgVarBody(fun)) == LAMBDA
+ && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
+ )
+ ) {
AsmSp start = asmBeginMkPAP(bco);
map1Proc(pushAtom,bco,reverse(args));
pushAtom(bco,fun);
diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 112ae6d31960b127db77c1c388e6bb4cb506e27e..97e3eef3a0626eaddef1c7857c43c0e03f72fdcf 100644
--- a/ghc/interpreter/compiler.c
+++ b/ghc/interpreter/compiler.c
@@ -10,8 +10,8 @@
* in the distribution for details.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:06:48 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:46 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -181,7 +181,7 @@ Cell e; {
nv));
}
- default : internal("translate");
+ default : fprintf(stderr, "stuff=%d\n",whatIs(e));internal("translate");
}
return e;
}
diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h
index 3c444bd06d42ca468b9feba919a4aee0c9b999ed..41dc004919a4a13a3291e490747d37346fa282fb 100644
--- a/ghc/interpreter/connect.h
+++ b/ghc/interpreter/connect.h
@@ -7,8 +7,8 @@
* in the distribution for details.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:06:50 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:45 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
@@ -497,4 +497,35 @@ extern List offsetTyvarsIn Args((Type,List));
extern Void optimiseTopBinds Args((List));
extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
+extern Void interface Args((Int));
+
+extern List typeVarsIn Args((Cell,List,List));
+
+extern Void getFileSize Args((String, Long *));
+
+extern Void loadInterface Args((String,Long));
+
+extern Void openGHCIface Args((Text));
+extern Void loadSharedLib Args((String));
+extern Void addGHCImports Args((Int,Text,List));
+extern Void addGHCExports Args((Cell,List));
+extern Void addGHCVar Args((Int,Text,Type));
+extern Void addGHCSynonym Args((Int,Cell,List,Type));
+extern Void addGHCDataDecl Args((Int,List,Cell,List,List));
+extern Void addGHCNewType Args((Int,List,Cell,List,Cell));
+extern Void addGHCClass Args((Int,List,Cell,List,List));
+extern Void addGHCInstance Args((Int,List,Pair,Text));
+extern Void finishInterfaces Args((Void));
+
+extern Void hi_o_namesFromSrcName Args((String,String*,String* oName));
+extern Void parseInterface Args((String,Long));
+
+
#define SMALL_INLINE_SIZE 9
+
+
+// nasty hack, but seems an easy to convey the object name
+// and size to openGHCIface
+char nameObj[FILENAME_MAX+1];
+int sizeObj;
+
diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c
index 57653d578f822ec87265bef3b75320d6c3d0aacd..3fb2a615053dd8e0cbe206e253c7e89cd3de6723 100644
--- a/ghc/interpreter/dynamic.c
+++ b/ghc/interpreter/dynamic.c
@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: dynamic.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:45 $
+ * $Revision: 1.5 $
+ * $Date: 1999/06/07 17:22:31 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -21,7 +21,6 @@
#include <stdio.h>
#include <dlfcn.h>
-#if 0 /* apparently unused */
ObjectFile loadLibrary(fn)
String fn; {
return dlopen(fn,RTLD_NOW | RTLD_GLOBAL);
@@ -32,7 +31,6 @@ ObjectFile file;
String symbol; {
return dlsym(file,symbol);
}
-#endif
void* getDLLSymbol(dll,symbol) /* load dll and lookup symbol */
String dll;
diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index b9268d6869377e6b8cc2f03fa908eac88f842bd5..2f426c5cdf6f51c1f28176f9d2ea854c74ce640d 100644
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:06:52 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:43 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
@@ -77,13 +77,13 @@ static Int local argToInt Args((String));
static Void local loadProject Args((String));
static Void local clearProject Args((Void));
-static Void local addScriptName Args((String,Bool));
-static Bool local addScript Args((String,Long));
+static Bool local addScript Args((Int));
static Void local forgetScriptsFrom Args((Script));
static Void local setLastEdit Args((String,Int));
static Void local failed Args((Void));
static String local strCopy Args((String));
+
/* --------------------------------------------------------------------------
* Machine dependent code for Hugs interpreter:
* ------------------------------------------------------------------------*/
@@ -101,20 +101,39 @@ static Bool printing = FALSE; /* TRUE => currently printing value*/
static Bool showStats = FALSE; /* TRUE => print stats after eval */
static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
static Bool addType = FALSE; /* TRUE => print type with value */
-static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
Bool preludeLoaded = FALSE;
- Bool optimise = TRUE;
+ Bool optimise = FALSE;
+
+typedef
+ struct {
+ String modName; /* Module name */
+ Bool details; /* FALSE => remaining fields are invalid */
+ String path; /* Path to module */
+ String srcExt; /* ".hs" or ".lhs" if fromSource */
+ Time lastChange; /* Time of last change to script */
+ Bool fromSource; /* FALSE => load object code */
+ Bool postponed; /* Indicates postponed load */
+ Bool objLoaded;
+ Long size;
+ Long oSize;
+ }
+ ScriptInfo;
+
+static Void local makeStackEntry Args((ScriptInfo*,String));
+static Void local addStackEntry Args((String));
+
+static ScriptInfo scriptInfo[NUM_SCRIPTS];
-static String scriptName[NUM_SCRIPTS]; /* Script file names */
-static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
-static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
static Int numScripts; /* Number of scripts loaded */
+static Int nextNumScripts;
static Int namesUpto; /* Number of script names set */
static Bool needsImports; /* set to TRUE if imports required */
String scriptFile; /* Name of current script (if any) */
+
+
static Text evalModule = 0; /* Name of module we eval exprs in */
static String currProject = 0; /* Name of current project file */
static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
@@ -131,6 +150,41 @@ static Int hpSize = DEFAULTHEAP; /* Desired heap size */
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;
+ 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
+ );
+ }
+ // printf ( "\n" );
+ fflush(stdout);fflush(stderr);
+ppScripts();
+ppModules();
+ printf ( "\n" );
+}
+
/* --------------------------------------------------------------------------
* Hugs entry point:
* ------------------------------------------------------------------------*/
@@ -228,6 +282,9 @@ String argv[]; {
startupHaskell (argc,argv);
argc = prog_argc; argv = prog_argv;
+ namesUpto = numScripts = 0;
+ addStackEntry("Prelude");
+
for (i=1; i<argc; ++i) { /* process command line arguments */
if (strcmp(argv[i], "--")==0) break;
if (strcmp(argv[i],"+")==0 && i+1<argc) {
@@ -239,7 +296,7 @@ String argv[]; {
}
} else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
&& !processOption(argv[i])) {
- addScriptName(argv[i],TRUE);
+ addStackEntry(argv[i]);
}
}
@@ -247,12 +304,15 @@ String argv[]; {
DEBUG_LoadSymbols(argv_0_orig);
#endif
- scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
+
+
+#if 0
if (!scriptName[0]) {
Printf("Prelude not found on current path: \"%s\"\n",
hugsPath ? hugsPath : "");
fatal("Unable to load prelude");
}
+#endif
if (haskell98) {
Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
@@ -655,7 +715,6 @@ struct options toggle[] = { /* List of command line toggles */
{'w', "Always show which modules are loaded", &listScripts},
{'k', "Show kind errors in full", &kindExpert},
{'o', "Allow overlapping instances", &allowOverlap},
- {'i', "Chase imports while loading modules", &chaseImports},
{'O', "Optimise (improve?) generated code", &optimise},
#if DEBUG_CODE
{'D', "Debug: show generated code", &debugCode},
@@ -705,7 +764,7 @@ String s; {
scriptFile = currProject;
forgetScriptsFrom(1);
while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
+ addStackEntry(s);
if (namesUpto<=1) {
ERRMSG(0) "Empty project file"
EEND;
@@ -724,107 +783,216 @@ static Void local clearProject() { /* clear name for current project */
#endif
}
-static Void local addScriptName(s,sch) /* Add script to list of scripts */
-String s; /* to be read in ... */
-Bool sch; { /* TRUE => requires pathname search*/
+
+
+static Void local makeStackEntry ( ScriptInfo* ent, String iname )
+{
+ Bool ok, fromObj;
+ Bool sAvail, iAvail, oAvail;
+ Time sTime, iTime, oTime;
+ Long sSize, iSize, oSize;
+ String path, sExt;
+
+ ok = findFilesForModule (
+ iname,
+ &path,
+ &sExt,
+ &sAvail, &sTime, &sSize,
+ &iAvail, &iTime, &iSize,
+ &oAvail, &oTime, &oSize
+ );
+ if (!ok) {
+ ERRMSG(0)
+ "Can't file source or object+interface 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 */
+ fromObj = sAvail
+ ? (oAvail && iAvail && timeEarlier(sTime,oTime))
+ : TRUE;
+ /* 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 Void nukeEnding( String s )
+{
+ Int l = strlen(s);
+ if (l > 2 && strncmp(s+l-2,".o" ,3)==0) s[l-2] = 0; else
+ if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 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;
+
if (namesUpto>=NUM_SCRIPTS) {
ERRMSG(0) "Too many module files (maximum of %d allowed)",
NUM_SCRIPTS
EEND;
}
- else
- scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
+
+ s = strCopy(s);
+ nukeEnding(s);
+ for (s2 = s; *s2; s2++)
+ if (*s2 == SLASH && *(s2+1)) s = s2+1;
+
+ found = FALSE;
+ for (i = 0; i < namesUpto; i++)
+ if (strcmp(scriptInfo[i].modName,s)==0)
+ found = TRUE;
+
+ if (!found) {
+ makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
+ namesUpto++;
+ }
+ free(s);
}
-static Bool local addScript(fname,len) /* read single script file */
-String fname; /* name of script file */
-Long len; { /* length of script file */
- scriptFile = fname;
+/* Return TRUE if no imports were needed; FALSE otherwise. */
+static Bool local addScript(stacknum) /* read single file */
+Int stacknum; {
+ static char name[FILENAME_MAX+1];
+ Int len = scriptInfo[stacknum].size;
#if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
allowBreak();
SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif
- Printf("Reading file \"%s\":\n",fname);
- setLastEdit(fname,0);
-
-#if 0
-ToDo: reinstate
- if (isInterfaceFile(fname)) {
- loadInterface(fname);
- } else
-#else
- {
- needsImports = FALSE;
- parseScript(fname,len); /* process script file */
- if (needsImports)
- return FALSE;
- checkDefns();
- typeCheckDefns();
- compileDefns();
- }
-#endif
- scriptFile = 0;
- preludeLoaded = TRUE;
- return TRUE;
+ // setLastEdit(name,0);
+
+ nameObj[0] = 0;
+ strcpy(name, scriptInfo[stacknum].path);
+ strcat(name, scriptInfo[stacknum].modName);
+ if (scriptInfo[stacknum].fromSource)
+ strcat(name, scriptInfo[stacknum].srcExt); else
+ strcat(name, ".hi");
+
+ scriptFile = name;
+
+ if (scriptInfo[stacknum].fromSource) {
+ Printf("Reading script \"%s\":\n",name);
+ needsImports = FALSE;
+ parseScript(name,len);
+ if (needsImports) return FALSE;
+ checkDefns();
+ typeCheckDefns();
+ compileDefns();
+ } else {
+ 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;
+
+ loadInterface(name,len);
+ scriptFile = 0;
+ if (needsImports) return FALSE;
+ }
+
+ scriptFile = 0;
+ preludeLoaded = TRUE;
+ return TRUE;
}
+
Bool chase(imps) /* Process list of import requests */
List imps; {
- if (chaseImports) {
- Int origPos = numScripts; /* keep track of original position */
- String origName = scriptName[origPos];
- for (; nonNull(imps); imps=tl(imps)) {
- String iname = findPathname(origName,textToStr(textOf(hd(imps))));
- Int i = 0;
- for (; i<namesUpto; i++)
- if (pathCmp(scriptName[i],iname)==0)
- break;
- if (i>=origPos) { /* Neither loaded or queued */
- String theName;
- Time theTime;
- Bool thePost;
-
- postponed[origPos] = TRUE;
- needsImports = TRUE;
-
- if (i>=namesUpto) /* Name not found (i==namesUpto) */
- addScriptName(iname,FALSE);
- else if (postponed[i]) {/* Check for recursive dependency */
- ERRMSG(0)
- "Recursive import dependency between \"%s\" and \"%s\"",
- scriptName[origPos], iname
- EEND;
- }
- /* Right rotate section of tables between numScripts and i so
- * that i ends up with other imports in front of orig. script
- */
- theName = scriptName[i];
- thePost = postponed[i];
- timeSet(theTime,lastChange[i]);
- for (; i>numScripts; i--) {
- scriptName[i] = scriptName[i-1];
- postponed[i] = postponed[i-1];
- timeSet(lastChange[i],lastChange[i-1]);
- }
- scriptName[numScripts] = theName;
- postponed[numScripts] = thePost;
- timeSet(lastChange[numScripts],theTime);
- origPos++;
+ 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;
+
+ needsImports = TRUE;
+ if (scriptInfo[origPos].fromSource)
+ scriptInfo[origPos].postponed = TRUE;
+
+ if (i==namesUpto) { /* Name not found (i==namesUpto) */
+ /* Find out where it lives, whether source or object, etc */
+ makeStackEntry ( &scriptInfo[i], iname );
+ namesUpto++;
+ }
+ else
+ if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
+ /* Check for recursive dependency */
+ ERRMSG(0)
+ "Recursive import dependency between \"%s\" and \"%s\"",
+ scriptInfo[origPos].modName, iname
+ EEND;
}
+ /* Move stack entry i to somewhere below origPos. If i denotes
+ * an object, destination is immediately below origPos.
+ * Otherwise, it's underneath the queue of objects below origPos.
+ */
+ dstPosn = origPos-1;
+ if (scriptInfo[i].fromSource)
+ while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
+ dstPosn--;
+
+ dstPosn++;
+ tmp = scriptInfo[i];
+ for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
+ scriptInfo[dstPosn] = tmp;
+ if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
+ origPos++;
}
- return needsImports;
}
- return FALSE;
+ return needsImports;
}
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)
@@ -839,7 +1007,7 @@ 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)
- addScriptName(s,TRUE);
+ addStackEntry(s);
readScripts(1);
}
@@ -868,12 +1036,16 @@ 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];
+ ppSmStack("readscripts-begin");
#if HUGS_FOR_WINDOWS
SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif
+#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);
@@ -883,8 +1055,10 @@ Int n; { /* loading everything after and */
}
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 */
@@ -894,11 +1068,85 @@ Int n; { /* loading everything after and */
else
dropScriptsFrom(numScripts-1);
}
+#endif
+
+ 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, ".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;
+
+ //numScripts = 0;
+
+ while (numScripts < namesUpto) {
+ppSmStack ( "readscripts-loop2" );
+
+ if (scriptInfo[numScripts].fromSource) {
+
+ if (numScripts>0)
+ startNewScript(scriptInfo[numScripts].modName);
+ nextNumScripts = NUM_SCRIPTS; //bogus initialisation
+ if (addScript(numScripts)) {
+ numScripts++;
+assert(nextNumScripts==NUM_SCRIPTS);
+ }
+ else
+ dropScriptsFrom(numScripts-1);
+ } else {
+
+ 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") ;
+ }
+
+ finishInterfaces();
+
+ { Int m = namesUpto-1;
+ Text mtext = findText(scriptInfo[m].modName);
+ setCurrModule(mtext);
+ evalModule = mtext;
+ }
+
+
if (listScripts)
whatScripts();
if (numScripts<=1)
setLastEdit((String)0, 0);
+ ppSmStack("readscripts-end ");
}
static Void local whatScripts() { /* list scripts in current session */
@@ -907,7 +1155,7 @@ static Void local whatScripts() { /* list scripts in current session */
if (projectLoaded)
Printf(" (project: %s)",currProject);
for (i=0; i<numScripts; ++i)
- Printf("\n%s",scriptName[i]);
+ Printf("\n%s",scriptInfo[i].modName);
Putchar('\n');
}
@@ -928,6 +1176,9 @@ static Void local editor() { /* interpreter-editor interface */
}
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) {
ERRMSG(0) "No name specified"
@@ -955,6 +1206,7 @@ static Void local find() { /* edit file containing definition */
EEND;
}
}
+#endif
}
static Void local runEditor() { /* run editor on script lastEdit */
@@ -1158,7 +1410,7 @@ Cell c; {
extern Name nameHw;
-static Void local dumpStg() { /* print STG stuff */
+static Void local dumpStg( void ) { /* print STG stuff */
String s;
Text t;
Name n;
@@ -1201,8 +1453,9 @@ static Void local dumpStg() { /* print STG stuff */
if (isNull(name(n).stgVar)) {
Printf ( "Doesn't have a STG tree: %s\n", s );
} else {
- printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
- Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(name(n).stgVar)));
+ Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
+ Printf ( "{- stgSize of body is %d -}\n\n",
+ stgSize(stgVarBody(name(n).stgVar)));
printStg(stderr, name(n).stgVar);
}
}
@@ -1222,12 +1475,13 @@ static Void local info() { /* describe objects */
}
}
+
static Void local describe(t) /* describe an object */
Text t; {
Tycon tc = findTycon(t);
Class cl = findClass(t);
Name nm = findName(t);
- //Module mod = findEvalModule();
+ Module mod = findModule(t);
if (nonNull(tc)) { /* as a type constructor */
Type t = tc;
@@ -1361,16 +1615,35 @@ Text t; {
} else if (isSfun(nm)) {
Printf(" -- selector function");
}
-#if 0
- ToDo: reinstate
- if (name(nm).primDef) {
- Printf(" -- primitive");
+ Printf("\n\n");
+ }
+
+ if (nonNull(mod)) { /* as a module */
+ List t;
+ Printf("-- module\n");
+
+ Printf("\n-- values\n");
+ for (t=module(mod).names; nonNull(t); t=tl(t)) {
+ Name nm = hd(t);
+ Printf ( "%s ", textToStr(name(nm).text));
}
-#endif
+
+ Printf("\n\n-- type constructors\n");
+ for (t=module(mod).tycons; nonNull(t); t=tl(t)) {
+ Tycon tc = hd(t);
+ Printf ( "%s ", textToStr(tycon(tc).text));
+ }
+
+ Printf("\n\n-- classes\n");
+ for (t=module(mod).classes; nonNull(t); t=tl(t)) {
+ Class cl = hd(t);
+ Printf ( "%s ", textToStr(cclass(cl).text));
+ }
+
Printf("\n\n");
}
- if (isNull(tc) && isNull(cl) && isNull(nm)) {
+ if (isNull(tc) && isNull(cl) && isNull(nm) && isNull(mod)) {
Printf("Unknown reference `%s'\n",textToStr(t));
}
}
diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c
index cc11551ff3a45d946c102372ac1327307d6cc26e..afae01fd1f7dac65f59339ac1207342a91a1c00f 100644
--- a/ghc/interpreter/input.c
+++ b/ghc/interpreter/input.c
@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: input.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/04/27 10:06:53 $
+ * $Revision: 1.6 $
+ * $Date: 1999/06/07 17:22:32 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -18,6 +18,7 @@
#include "connect.h"
#include "command.h"
#include "errors.h"
+#include "link.h"
#include <ctype.h>
#if HAVE_GETDELIM_H
#include "getdelim.h"
@@ -48,6 +49,7 @@ List evalDefaults = NIL; /* defaults for evaluator */
Cell inputExpr = NIL; /* input expression */
Bool literateScripts = FALSE; /* TRUE => default to lit scripts */
Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */
+Bool offsideON = TRUE; /* TRUE => implement offside rule */
String repeatStr = 0; /* Repeat last expr */
@@ -120,9 +122,9 @@ static Text textBar, textMinus, textFrom, textArrow, textLazy;
static Text textBang, textDot, textAll, textImplies;
static Text textWildcard;
-static Text textModule, textImport;
+static Text textModule, textImport, textInterface, textInstImport;
static Text textHiding, textQualified, textAsMod;
-static Text textExport, textUnsafe;
+static Text textExport, textUnsafe, text__All;
Text textNum; /* Num */
Text textPrelude; /* Prelude */
@@ -249,7 +251,8 @@ static String nextStringChar; /* next char in string buffer */
#if USE_READLINE /* for command line editors */
static String currentLine; /* editline or GNU readline */
static String nextChar;
-#define nextConsoleChar() (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
+#define nextConsoleChar() \
+ (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
extern Void add_history Args((String));
extern String readline Args((String));
#else
@@ -398,6 +401,35 @@ String nm; {
}
+Void hi_o_namesFromSrcName ( String srcName, String* hiName, String* oName )
+{
+ Int len;
+ String dot;
+ len = 1 + strlen ( srcName );
+ *hiName = malloc(len);
+ *oName = malloc(len);
+ if (!(*hiName && *oName)) internal("hi_o_namesFromSource");
+ (*hiName)[0] = (*oName)[0] = 0;
+ dot = strrchr(srcName, '.');
+ if (!dot) return;
+ if (filenamecmp(dot+1, "hs")==0 &&
+ filenamecmp(dot+1, "lhs")==0 &&
+ filenamecmp(dot+1, "verb")==0) return;
+
+ strcpy(*hiName, srcName);
+ dot = strrchr(*hiName, '.');
+ dot[1] = 'h';
+ dot[2] = 'i';
+ dot[3] = 0;
+
+ strcpy(*oName, srcName);
+ dot = strrchr(*oName, '.');
+ dot[1] = 'o';
+ dot[2] = 0;
+}
+
+
+
/* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
* I've removed the loop (since newLineSkip contains a loop too) and
* replaced the warnings with errors. ADR
@@ -449,7 +481,8 @@ static Int local nextLine()
if (lineLength <= 0) { /* EOF / IO error, who knows.. */
return lineLength;
}
- else if (lineLength >= 2 && lineBuffer[0] == '#' && lineBuffer[1] == '!') {
+ else if (lineLength >= 2 && lineBuffer[0] == '#' &&
+ lineBuffer[1] == '!') {
lineBuffer[0]='\n'; /* pretend it's a blank line */
lineBuffer[1]='\0';
lineLength=1;
@@ -1215,6 +1248,7 @@ static Int indentDepth = (-1); /* current indentation nesting */
static Void local goOffside(col) /* insert offside marker */
Int col; { /* for specified column */
+assert(offsideON);
if (indentDepth>=MAXINDENT) {
ERRMSG(row) "Too many levels of program nesting"
EEND;
@@ -1223,10 +1257,12 @@ Int col; { /* for specified column */
}
static Void local unOffside() { /* leave layout rule area */
+assert(offsideON);
indentDepth--;
}
static Bool local canUnOffside() { /* Decide if unoffside permitted */
+assert(offsideON);
return indentDepth>=0 && layout[indentDepth]!=HARD;
}
@@ -1298,7 +1334,7 @@ static Int local yylex() { /* Read next input token ... */
return firstTokenIs;
}
- if (insertOpen) { /* insert `soft' opening brace */
+ if (offsideON && insertOpen) { /* insert `soft' opening brace */
insertOpen = FALSE;
insertedToken = TRUE;
goOffside(column);
@@ -1319,7 +1355,7 @@ static Int local yylex() { /* Read next input token ... */
if (insertedToken) /* avoid inserting multiple `;'s */
insertedToken = FALSE; /* or putting `;' after `{' */
else
- if (layout[indentDepth]!=HARD) {
+ if (offsideON && layout[indentDepth]!=HARD) {
if (column<layout[indentDepth]) {
unOffside();
return '}';
@@ -1346,16 +1382,17 @@ static Int local yylex() { /* Read next input token ... */
case '[' : skip(); return '[';
case ']' : skip(); return ']';
case '`' : skip(); return '`';
- case '{' : goOffside(HARD);
+ case '{' : if (offsideON) goOffside(HARD);
skip();
return '{';
- case '}' : if (indentDepth<0) {
+ case '}' : if (offsideON && indentDepth<0) {
ERRMSG(row) "Misplaced `}'"
EEND;
}
- if (layout[indentDepth]==HARD) /* skip over hard }*/
- skip();
- unOffside(); /* otherwise, we have to insert a }*/
+ if (!(offsideON && layout[indentDepth]!=HARD))
+ skip(); /* skip over hard }*/
+ if (offsideON)
+ unOffside(); /* otherwise, we have to insert a }*/
return '}'; /* to (try to) avoid an error... */
/* Character and string literals */
@@ -1429,6 +1466,8 @@ static Int local yylex() { /* Read next input token ... */
if (it==textClass) return TCLASS;
if (it==textInstance) return TINSTANCE;
if (it==textModule) return TMODULE;
+ if (it==textInterface) return INTERFACE;
+ if (it==textInstImport) return INSTIMPORT;
if (it==textImport) return IMPORT;
if (it==textExport) return EXPORT;
if (it==textHiding) return HIDING;
@@ -1436,6 +1475,7 @@ static Int local yylex() { /* Read next input token ... */
if (it==textAsMod) return ASMOD;
if (it==textWildcard) return '_';
if (it==textAll && !haskell98) return ALL;
+ if (it==text__All) return ALL;
if (it==textRepeat && reading==KEYBOARD)
return repeatLast();
@@ -1472,7 +1512,8 @@ static Int local yylex() { /* Read next input token ... */
return NUMLIT;
}
- ERRMSG(row) "Unrecognised character `\\%d' in column %d", ((int)c0), column
+ ERRMSG(row) "Unrecognised character `\\%d' in column %d",
+ ((int)c0), column
EEND;
return 0; /*NOTREACHED*/
}
@@ -1506,6 +1547,9 @@ static Void local parseInput(startWith)/* Parse input with given first tok,*/
Int startWith; { /* determining whether to read a */
firstToken = TRUE; /* script or an expression */
firstTokenIs = startWith;
+ if (startWith==INTERFACE)
+ offsideON = FALSE; else
+ offsideON = TRUE;
clearStack();
if (yyparse()) { /* This can only be parser overflow */
@@ -1570,6 +1614,15 @@ Void parseExp() { /* Read an expression to evaluate */
setLastExpr(inputExpr);
}
+Void parseInterface(nm,len) /* Read a GHC interface file */
+String nm;
+Long len; { /* Used to set a target for reading */
+ input(RESET);
+ fileInput(nm,len);
+ parseInput(INTERFACE);
+}
+
+
/* --------------------------------------------------------------------------
* Input control:
* ------------------------------------------------------------------------*/
@@ -1616,12 +1669,16 @@ Int what; {
textPrelude = findText("Prelude");
textNum = findText("Num");
textModule = findText("module");
+ textInterface = findText("__interface");
+ textInstImport = findText("__instimport");
+ textExport = findText("__export");
textImport = findText("import");
textHiding = findText("hiding");
textQualified = findText("qualified");
textAsMod = findText("as");
textWildcard = findText("_");
textAll = findText("forall");
+ text__All = findText("__forall");
varMinus = mkVar(textMinus);
varPlus = mkVar(textPlus);
varBang = mkVar(textBang);
diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
new file mode 100644
index 0000000000000000000000000000000000000000..b754bc5a39bf7861a80ee43556a6328476a82ee8
--- /dev/null
+++ b/ghc/interpreter/interface.c
@@ -0,0 +1,1652 @@
+
+/* --------------------------------------------------------------------------
+ * GHC interface file processing for Hugs
+ *
+ * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
+ * All rights reserved. See NOTICE for details and conditions of use etc...
+ * Hugs version 1.4, December 1997
+ *
+ * $RCSfile: interface.c,v $
+ * $Revision: 1.4 $
+ * $Date: 1999/06/07 17:22:51 $
+ * ------------------------------------------------------------------------*/
+
+/* ToDo:
+ * o use Z encoding
+ * o use vectored CONSTR_entry when appropriate
+ * o generate export list
+ *
+ * Needs GHC changes to generate member selectors,
+ * superclass selectors, etc
+ * o instance decls
+ * o dictionary constructors ?
+ *
+ * o Get Hugs/GHC to agree on what interface files look like.
+ * o figure out how to replace the Hugs Prelude with the GHC Prelude
+ */
+
+#include "prelude.h"
+#include "storage.h"
+#include "backend.h"
+#include "connect.h"
+#include "errors.h"
+#include "link.h"
+#include "Assembler.h" /* for wrapping GHC objects */
+#include "dynamic.h"
+
+#define DEBUG_IFACE
+
+/* --------------------------------------------------------------------------
+ * The "addGHC*" functions act as "impedence matchers" between GHC
+ * interface files and Hugs. Their main job is to convert abstract
+ * syntax trees into Hugs' internal representations.
+ *
+ * The main trick here is how we deal with mutually recursive interface
+ * files:
+ *
+ * o As we read an import decl, we add it to a list of required imports
+ * (unless it's already loaded, of course).
+ *
+ * o Processing of declarations is split into two phases:
+ *
+ * 1) While reading the interface files, we construct all the Names,
+ * Tycons, etc declared in the interface file but we don't try to
+ * resolve references to any entities the declaration mentions.
+ *
+ * This is done by the "addGHC*" functions.
+ *
+ * 2) After reading all the interface files, we finish processing the
+ * declarations by resolving any references in the declarations
+ * and doing any other processing that may be required.
+ *
+ * This is done by the "finishGHC*" functions which use the
+ * "fixup*" functions to assist them.
+ *
+ * The interface between these two phases are the "ghc*Decls" which
+ * contain lists of decls that haven't been completed yet.
+ *
+ * ------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * local variables:
+ * ------------------------------------------------------------------------*/
+
+static List ghcVarDecls;
+static List ghcConstrDecls;
+static List ghcSynonymDecls;
+static List ghcClassDecls;
+static List ghcInstanceDecls;
+
+/* --------------------------------------------------------------------------
+ * local function prototypes:
+ * ------------------------------------------------------------------------*/
+
+static List local addGHCConstrs Args((Int,List,List));
+static Name local addGHCSel Args((Int,Pair));
+static Name local addGHCConstr Args((Int,Int,Triple));
+
+
+static Void local finishGHCVar Args((Name));
+static Void local finishGHCConstr Args((Name));
+static Void local finishGHCSynonym Args((Tycon));
+static Void local finishGHCClass Args((Class));
+static Void local finishGHCInstance Args((Inst));
+static Void local finishGHCImports Args((Triple));
+static Void local finishGHCExports Args((Pair));
+static Void local finishGHCModule Args((Module));
+
+static Void local bindGHCNameTo Args((Name,Text));
+static Kinds local tvsToKind Args((List));
+static Int local arityFromType Args((Type));
+
+static List local ifTyvarsIn Args((Type));
+
+static Type local tvsToOffsets Args((Int,Type,List));
+static Type local conidcellsToTycons Args((Int,Type));
+
+static Void local resolveReferencesInObjectModule Args((Module));
+static Bool local validateOImage Args((void*, Int));
+
+static Text text_info;
+static Text text_entry;
+static Text text_closure;
+static Text text_static_closure;
+static Text text_static_info;
+static Text text_con_info;
+static Text text_con_entry;
+
+
+/* --------------------------------------------------------------------------
+ * code:
+ * ------------------------------------------------------------------------*/
+
+List ifImports; /* [ConId] -- modules imported by current interface */
+
+List ghcImports; /* [(Module, Text, [ConId|VarId])]
+ each (m1, m2, names) in this list
+ represents 'module m1 where ... import m2 ( names ) ...'
+ The list acts as a list of names to fix up in
+ finishInterfaces().
+ */
+
+List ghcExports; /* [(ConId, [ConId|VarId])] */
+
+List ghcModules; /* [Module] -- modules of the .his loaded in this group */
+
+Void addGHCExports(mod,stuff)
+Cell mod;
+List stuff; {
+ ghcExports = cons( pair(mod,stuff), ghcExports );
+}
+
+static Void local finishGHCExports(paire)
+Pair paire; {
+ Text modTxt = textOf(fst(paire));
+ List ids = snd(paire);
+ Module mod = findModule(modTxt);
+ if (isNull(mod)) {
+ ERRMSG(0) "Can't find module \"%s\" mentioned in export list",
+ textToStr(modTxt)
+ EEND;
+ }
+
+ for (; nonNull(ids); ids=tl(ids)) {
+ Cell xs;
+ Cell id = hd(ids); /* ConId|VarId */
+ Bool found = FALSE;
+ for (xs = module(mod).exports; nonNull(xs); xs=tl(xs)) {
+ Cell x = hd(xs);
+ if (isQCon(x)) continue; /* ToDo: fix this right */
+ if (textOf(x)==textOf(id)) { found = TRUE; break; }
+ }
+ if (!found) {
+printf ( "adding %s to exports of %s\n",
+ identToStr(id), textToStr(modTxt) );
+ module(mod).exports = cons ( id, module(mod).exports );
+ }
+ }
+}
+
+
+static Void local finishGHCImports(triple)
+Triple triple;
+{
+ Module dstMod = fst3(triple); // the importing module
+ Text srcTxt = snd3(triple);
+ List names = thd3(triple);
+ Module srcMod = findModule ( srcTxt );
+ Module tmpCurrentModule = currentModule;
+ List exps;
+ Bool found;
+ Text tnm;
+ Cell nm;
+ Cell x;
+ //fprintf(stderr, "finishGHCImports: dst=%s src=%s\n",
+ // textToStr(module(dstMod).text),
+ // textToStr(srcTxt) );
+ //print(names, 100);
+ //printf("\n");
+ /* for each nm in names
+ nm should be in module(src).exports -- if not, error
+ if nm notElem module(dst).names cons it on
+ */
+
+ if (isNull(srcMod)) {
+ /* I don't think this can actually ever happen, but still ... */
+ ERRMSG(0) "Interface for module \"%s\" imports unknown module \"%s\"",
+ textToStr(module(dstMod).text),
+ textToStr(srcTxt)
+ EEND;
+ }
+ //printf ( "exports of %s are\n", textToStr(module(srcMod).text) );
+ //print( module(srcMod).exports, 100 );
+ //printf( "\n" );
+
+ setCurrModule ( srcMod ); // so that later lookups succeed
+
+ for (; nonNull(names); names=tl(names)) {
+ nm = hd(names);
+ /* Check the exporting module really exports it. */
+ found = FALSE;
+ for (exps=module(srcMod).exports; nonNull(exps); exps=tl(exps)) {
+ Cell c = hd(exps);
+ //if (isPair(c)) c=fst(c);
+ assert(whatIs(c)==CONIDCELL || whatIs(c)==VARIDCELL);
+ assert(whatIs(nm)==CONIDCELL || whatIs(nm)==VARIDCELL);
+ //printf( " compare `%s' `%s'\n", textToStr(textOf(c)), textToStr(textOf(nm)));
+ if (textOf(c)==textOf(nm)) { found=TRUE; break; }
+ }
+ if (!found) {
+ ERRMSG(0) "Interface for module \"%s\" imports \"%s\" from\n"
+ "module \"%s\", but the latter doesn't export it",
+ textToStr(module(dstMod).text), textToStr(textOf(nm)),
+ textToStr(module(srcMod).text)
+ EEND;
+ }
+ /* Ok, it's exported. Now figure out what it is we're really
+ importing.
+ */
+ tnm = textOf(nm);
+
+ x = findName(tnm);
+ if (nonNull(x)) {
+ if (!cellIsMember(x,module(dstMod).names))
+ module(dstMod).names = cons(x, module(dstMod).names);
+ continue;
+ }
+
+ x = findTycon(tnm);
+ if (nonNull(x)) {
+ if (!cellIsMember(x,module(dstMod).tycons))
+ module(dstMod).tycons = cons(x, module(dstMod).tycons);
+ continue;
+ }
+
+ x = findClass(tnm);
+ if (nonNull(x)) {
+ if (!cellIsMember(x,module(dstMod).classes))
+ module(dstMod).classes = cons(x, module(dstMod).classes);
+ continue;
+ }
+
+ fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n"
+ "\t%s\n", textToStr(tnm) );
+ internal("finishGHCImports");
+ }
+
+ setCurrModule(tmpCurrentModule);
+}
+
+
+Void loadInterface(String fname, Long fileSize)
+{
+ ifImports = NIL;
+ parseInterface(fname,fileSize);
+ if (nonNull(ifImports))
+ chase(ifImports);
+}
+
+
+Void finishInterfaces ( void )
+{
+ /* the order of these doesn't matter
+ * (ToDo: unless synonyms have to be eliminated??)
+ */
+ mapProc(finishGHCVar, ghcVarDecls);
+ mapProc(finishGHCConstr, ghcConstrDecls);
+ mapProc(finishGHCSynonym, ghcSynonymDecls);
+ mapProc(finishGHCClass, ghcClassDecls);
+ mapProc(finishGHCInstance, ghcInstanceDecls);
+ mapProc(finishGHCExports, ghcExports);
+ mapProc(finishGHCImports, ghcImports);
+ mapProc(finishGHCModule, ghcModules);
+ ghcVarDecls = NIL;
+ ghcConstrDecls = NIL;
+ ghcSynonymDecls = NIL;
+ ghcClassDecls = NIL;
+ ghcInstanceDecls = NIL;
+ ghcImports = NIL;
+ ghcExports = NIL;
+ ghcModules = NIL;
+}
+
+
+static Void local finishGHCModule(mod)
+Module mod; {
+ // do the implicit 'import Prelude' thing
+ List pxs = module(modulePrelude).exports;
+ for (; nonNull(pxs); pxs=tl(pxs)) {
+ Cell px = hd(pxs);
+ again:
+ switch (whatIs(px)) {
+ case AP:
+ px = fst(px);
+ goto again;
+ case NAME:
+ module(mod).names = cons ( px, module(mod).names );
+ break;
+ case TYCON:
+ module(mod).tycons = cons ( px, module(mod).tycons );
+ break;
+ case CLASS:
+ module(mod).classes = cons ( px, module(mod).classes );
+ break;
+ default:
+ fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
+ break;
+ }
+ }
+
+ // Last, but by no means least ...
+ resolveReferencesInObjectModule ( mod );
+}
+
+Void openGHCIface(t)
+Text t; {
+ FILE* f;
+ void* img;
+ Module m = findModule(t);
+ if (isNull(m)) {
+ m = newModule(t);
+printf ( "new module %s\n", textToStr(t) );
+ } else if (m != modulePrelude) {
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
+ EEND;
+ }
+
+ // sizeObj and nameObj will magically be set to the right
+ // thing when we arrive here.
+ // All this crud should be replaced with mmap when we do this
+ // for real(tm)
+ img = malloc ( sizeObj );
+ if (!img) {
+ ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+ f = fopen( nameObj, "rb" );
+ if (!f) {
+ // Really, this shouldn't happen, since makeStackEntry ensures the
+ // object is available. Nevertheless ...
+ ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
+ &(nameObj[0])
+ EEND;
+ }
+ if (sizeObj != fread ( img, 1, sizeObj, f)) {
+ ERRMSG(0) "Read of object file \"%s\" failed", nameObj
+ EEND;
+ }
+ if (!validateOImage(img,sizeObj)) {
+ ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
+ EEND;
+ }
+
+ assert(!module(m).oImage);
+ module(m).oImage = img;
+
+ if (!cellIsMember(m, ghcModules))
+ ghcModules = cons(m, ghcModules);
+
+ setCurrModule(m);
+}
+
+
+Void addGHCImports(line,mn,syms)
+Int line;
+Text mn; /* the module to import from */
+List syms; { /* [ConId | VarId] -- the names to import */
+ List t;
+ Bool found;
+# ifdef DEBUG_IFACE
+ printf("\naddGHCImport %s\n", textToStr(mn) );
+# endif
+
+ // Hack to avoid chasing Prel* junk right now
+ if (strncmp(textToStr(mn), "Prel",4)==0) return;
+
+ found = FALSE;
+ for (t=ifImports; nonNull(t); t=tl(t)) {
+ if (textOf(hd(t)) == mn) {
+ found = TRUE;
+ break;
+ }
+ }
+ if (!found) {
+ ifImports = cons(mkCon(mn),ifImports);
+ ghcImports = cons( triple(currentModule,mn,syms), ghcImports );
+ }
+}
+
+void addGHCVar(line,v,ty)
+Int line;
+Text v;
+Type ty;
+{
+ Name n;
+ String s;
+ List tmp, tvs;
+ /* if this var is the name of a ghc-compiled dictionary,
+ ie, starts zdfC where C is a capital,
+ ignore it.
+ */
+ s = textToStr(v);
+# ifdef DEBUG_IFACE
+ printf("\nbegin addGHCVar %s\n", s);
+# endif
+ if (s[0]=='z' && s[1]=='d' && s[2]=='f' && isupper((int)s[3])) {
+# ifdef DEBUG_IFACE
+ printf(" ignoring %s\n", s);
+# endif
+ return;
+ }
+ n = findName(v);
+ if (nonNull(n)) {
+ ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
+ EEND;
+ }
+ n = newName(v,NIL);
+ bindGHCNameTo(n, text_info);
+ bindGHCNameTo(n, text_closure);
+
+ tvs = nubList(ifTyvarsIn(ty));
+ for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
+ hd(tmp) = pair(hd(tmp),STAR);
+ if (nonNull(tvs))
+ ty = mkPolyType(tvsToKind(tvs),ty);
+
+ ty = tvsToOffsets(line,ty,tvs);
+
+ /* prepare for finishGHCVar */
+ name(n).type = ty;
+ name(n).line = line;
+ ghcVarDecls = cons(n,ghcVarDecls);
+# ifdef DEBUG_IFACE
+ printf("end addGHCVar %s\n", s);
+# endif
+}
+
+static Void local finishGHCVar(Name n)
+{
+ Int line = name(n).line;
+ Type ty = name(n).type;
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) );
+# endif
+ setCurrModule(name(n).mod);
+ name(n).type = conidcellsToTycons(line,ty);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "end finishGHCVar %s\n", textToStr(name(n).text) );
+# endif
+}
+
+Void addGHCSynonym(line,tycon,tvs,ty)
+Int line;
+Cell tycon; /* ConId */
+List tvs; /* [(VarId,Kind)] */
+Type ty; {
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+ Text t = textOf(tycon);
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = line;
+ tycon(tc).arity = length(tvs);
+ tycon(tc).what = SYNONYM;
+ tycon(tc).kind = tvsToKind(tvs);
+
+ /* prepare for finishGHCSynonym */
+ tycon(tc).defn = tvsToOffsets(line,ty,tvs);
+ ghcSynonymDecls = cons(tc,ghcSynonymDecls);
+ }
+}
+
+static Void local finishGHCSynonym(Tycon tc)
+{
+ Int line = tycon(tc).line;
+
+ setCurrModule(tycon(tc).mod);
+ tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
+
+ /* ToDo: can't really do this until I've done all synonyms
+ * and then I have to do them in order
+ * tycon(tc).defn = fullExpand(ty);
+ */
+}
+
+Void addGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
+Int line;
+List ctx0; /* [(QConId,VarId)] */
+Cell tycon; /* ConId */
+List ktyvars; /* [(VarId,Kind)] */
+List constrs0; /* [(ConId,[(Type,Text)],NIL)]
+ The NIL will become the constr's type
+ The Text is an optional field name */
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+{
+ Type ty, resTy, selTy, conArgTy;
+ List tmp, conArgs, sels, constrs, fields, tyvarsMentioned;
+ List ctx, ctx2;
+ Triple constr;
+ Cell conid;
+ Pair conArg, ctxElem;
+ Text conArgNm;
+
+ Text t = textOf(tycon);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t));
+# endif
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).text = t;
+ tycon(tc).line = line;
+ tycon(tc).arity = length(ktyvars);
+ tycon(tc).kind = tvsToKind(ktyvars);
+ tycon(tc).what = DATATYPE;
+
+ /* a list to accumulate selectors in :: [(VarId,Type)] */
+ sels = NIL;
+
+ /* make resTy the result type of the constr, T v1 ... vn */
+ resTy = tycon;
+ for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
+ resTy = ap(resTy,fst(hd(tmp)));
+
+ /* for each constructor ... */
+ for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
+ constr = hd(constrs);
+ conid = fst3(constr);
+ fields = snd3(constr);
+ assert(isNull(thd3(constr)));
+
+ /* Build type of constr and handle any selectors found.
+ Also collect up tyvars occurring in the constr's arg
+ types, so we can throw away irrelevant parts of the
+ context later.
+ */
+ ty = resTy;
+ tyvarsMentioned = NIL; /* [VarId] */
+ conArgs = reverse(fields);
+ for (; nonNull(conArgs); conArgs=tl(conArgs)) {
+ conArg = hd(conArgs); /* (Type,Text) */
+ conArgTy = fst(conArg);
+ conArgNm = snd(conArg);
+ tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
+ tyvarsMentioned);
+ ty = fn(conArgTy,ty);
+ if (nonNull(conArgNm)) {
+ /* a field name is mentioned too */
+ selTy = fn(resTy,conArgTy);
+ if (whatIs(tycon(tc).kind) != STAR)
+ selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
+ selTy = tvsToOffsets(line,selTy, ktyvars);
+
+ sels = cons( pair(conArgNm,selTy), sels);
+ }
+ }
+
+ /* Now ty is the constructor's type, not including context.
+ Throw away any parts of the context not mentioned in
+ tyvarsMentioned, and use it to qualify ty.
+ */
+ ctx2 = NIL;
+ for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
+ ctxElem = hd(ctx); /* (QConId,VarId) */
+ if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned)))
+ ctx2 = cons(ctxElem, ctx2);
+ }
+ if (nonNull(ctx2))
+ ty = ap(QUAL,pair(ctx2,ty));
+
+ /* stick the tycon's kind on, if not simply STAR */
+ if (whatIs(tycon(tc).kind) != STAR)
+ ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
+
+ ty = tvsToOffsets(line,ty, ktyvars);
+
+ /* Finally, stick the constructor's type onto it. */
+ thd3(hd(constrs)) = ty;
+ }
+
+ /* Final result is that
+ constrs :: [(ConId,[(Type,Text)],Type)]
+ lists the constructors and their types
+ sels :: [(VarId,Type)]
+ lists the selectors and their types
+ */
+ tycon(tc).defn = addGHCConstrs(line,constrs0,sels);
+ }
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "end addGHCDataDecl %s\n",textToStr(t));
+# endif
+}
+
+
+static List local addGHCConstrs(line,cons,sels)
+Int line;
+List cons; /* [(ConId,[(Type,Text)],Type)] */
+List sels; { /* [(VarId,Type)] */
+ List cs, ss;
+ Int conNo = 0; /* or maybe 1? */
+ for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
+ Name c = addGHCConstr(line,conNo,hd(cs));
+ hd(cs) = c;
+ }
+ for(ss=sels; nonNull(ss); ss=tl(ss)) {
+ hd(ss) = addGHCSel(line,hd(ss));
+ }
+ return appendOnto(cons,sels);
+}
+
+static Name local addGHCSel(line,sel)
+Int line;
+Pair sel; /* (VarId,Type) */
+{
+ Text t = textOf(fst(sel));
+ Type type = snd(sel);
+
+ Name n = findName(t);
+ if (nonNull(n)) {
+ ERRMSG(line) "Repeated definition for selector \"%s\"",
+ textToStr(t)
+ EEND;
+ }
+
+ n = newName(t,NIL);
+ name(n).line = line;
+ name(n).number = SELNAME;
+ name(n).arity = 1;
+ name(n).defn = NIL;
+
+ /* prepare for finishGHCVar */
+ name(n).type = type;
+ ghcVarDecls = cons(n,ghcVarDecls);
+
+ return n;
+}
+
+static Name local addGHCConstr(line,conNo,constr)
+Int line;
+Int conNo;
+Triple constr; { /* (ConId,[(Type,Text)],Type) */
+ /* ToDo: add rank2 annotation and existential annotation
+ * these affect how constr can be used.
+ */
+ Text con = textOf(fst3(constr));
+ Type type = thd3(constr);
+ Int arity = arityFromType(type);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+
+ if (arity == 0) {
+ // expect to find the names
+ // Mod_Con_closure
+ // Mod_Con_static_closure
+ // Mod_Con_static_info
+ bindGHCNameTo(n, text_closure);
+ bindGHCNameTo(n, text_static_closure);
+ bindGHCNameTo(n, text_static_info);
+ } else {
+ // expect to find the names
+ // Mod_Con_closure
+ // Mod_Con_entry
+ // Mod_Con_info
+ // Mod_Con_con_info
+ // Mod_Con_static_info
+ bindGHCNameTo(n, text_closure);
+ bindGHCNameTo(n, text_entry);
+ bindGHCNameTo(n, text_info);
+ bindGHCNameTo(n, text_con_info);
+ bindGHCNameTo(n, text_static_info);
+ }
+
+ /* prepare for finishGHCCon */
+ name(n).type = type;
+ ghcConstrDecls = cons(n,ghcConstrDecls);
+
+ return n;
+}
+
+static Void local finishGHCConstr(Name n)
+{
+ Int line = name(n).line;
+ Type ty = name(n).type;
+ setCurrModule(name(n).mod);
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text));
+# endif
+ name(n).type = conidcellsToTycons(line,ty);
+# ifdef DEBUG_IFACE
+ printf ( "end finishGHCConstr %s\n", textToStr(name(n).text));
+# endif
+}
+
+
+Void addGHCNewType(line,ctx0,tycon,tvs,constr)
+Int line;
+List ctx0; /* [(QConId,VarId)] */
+Cell tycon; /* ConId | QualConId */
+List tvs; /* [(VarId,Kind)] */
+Cell constr; { /* (ConId,Type) */
+ /* ToDo: worry about being given a decl for (->) ?
+ * and worry about qualidents for ()
+ */
+ List tmp;
+ Type resTy;
+ Text t = textOf(tycon);
+ if (nonNull(findTycon(t))) {
+ ERRMSG(line) "Repeated definition of type constructor \"%s\"",
+ textToStr(t)
+ EEND;
+ } else {
+ Tycon tc = newTycon(t);
+ tycon(tc).line = line;
+ tycon(tc).arity = length(tvs);
+ tycon(tc).what = NEWTYPE;
+ tycon(tc).kind = tvsToKind(tvs);
+ /* can't really do this until I've read in all synonyms */
+
+ assert(nonNull(constr));
+ if (isNull(constr)) {
+ tycon(tc).defn = NIL;
+ } else {
+ /* constr :: (ConId,Type) */
+ Text con = textOf(fst(constr));
+ Type type = snd(constr);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = 1; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(0);
+ name(n).defn = nameId;
+ tycon(tc).defn = singleton(n);
+
+ /* prepare for finishGHCCon */
+ /* ToDo: we use finishGHCCon instead of finishGHCVar in case
+ * there's any existential quantification in the newtype -
+ * but I don't think that's allowed in newtype constrs.
+ * Still, no harm done by doing it this way...
+ */
+
+ /* make resTy the result type of the constr, T v1 ... vn */
+ resTy = tycon;
+ for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
+ resTy = ap(resTy,fst(hd(tmp)));
+ type = fn(type,resTy);
+ if (nonNull(ctx0))
+ type = ap(QUAL,pair(ctx0,type));
+
+ type = tvsToOffsets(line,type,tvs);
+
+ name(n).type = type;
+ ghcConstrDecls = cons(n,ghcConstrDecls);
+ }
+ }
+}
+
+Void addGHCClass(line,ctxt,tc_name,tv,mems0)
+Int line;
+List ctxt; /* [(QConId, VarId)] */
+Cell tc_name; /* ConId */
+Text tv; /* VarId */
+List mems0; { /* [(VarId, Type)] */
+ List mems; /* [(VarId, Type)] */
+ List tvsInT; /* [VarId] and then [(VarId,Kind)] */
+ List tvs; /* [(VarId,Kind)] */
+ Text ct = textOf(tc_name);
+ Pair newCtx = pair(tc_name, tv);
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
+# endif
+ if (nonNull(findClass(ct))) {
+ ERRMSG(line) "Repeated definition of class \"%s\"",
+ textToStr(ct)
+ EEND;
+ } else if (nonNull(findTycon(ct))) {
+ ERRMSG(line) "\"%s\" used as both class and type constructor",
+ textToStr(ct)
+ EEND;
+ } else {
+ Class nw = newClass(ct);
+ cclass(nw).text = ct;
+ cclass(nw).line = line;
+ cclass(nw).arity = 1;
+ cclass(nw).head = ap(nw,mkOffset(0));
+ cclass(nw).kinds = singleton(STAR); /* absolutely no idea at all */
+ cclass(nw).instances = NIL; /* what the kind should be */
+ cclass(nw).numSupers = length(ctxt);
+
+ /* Kludge to map the single tyvar in the context to Offset 0.
+ Need to do something better for multiparam type classes.
+ */
+ cclass(nw).supers = tvsToOffsets(line,ctxt,
+ singleton(pair(tv,STAR)));
+
+ for (mems=mems0; nonNull(mems); mems=tl(mems)) {
+ Pair mem = hd(mems);
+ Type memT = snd(mem);
+
+ /* Stick the new context on the member type */
+ if (whatIs(memT)==POLYTYPE) internal("addGHCClass");
+ if (whatIs(memT)==QUAL) {
+ memT = pair(QUAL,
+ pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
+ } else {
+ memT = pair(QUAL,
+ pair(singleton(newCtx),memT));
+ }
+
+ /* Cook up a kind for the type. */
+ tvsInT = nubList(ifTyvarsIn(memT));
+
+ /* ToDo: maximally bogus */
+ for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
+ hd(tvs) = pair(hd(tvs),STAR);
+
+ memT = mkPolyType(tvsToKind(tvsInT),memT);
+ memT = tvsToOffsets(line,memT,tvsInT);
+
+ /* Park the type back on the member */
+ snd(mem) = memT;
+ }
+
+ cclass(nw).members = mems0;
+ cclass(nw).numMembers = length(mems0);
+ ghcClassDecls = cons(nw,ghcClassDecls);
+
+ /* ToDo:
+ * cclass(nw).dsels = ?;
+ * cclass(nw).dbuild = ?;
+ * cclass(nm).dcon = ?;
+ * cclass(nm).defaults = ?;
+ */
+ }
+# ifdef DEBUG_IFACE
+ printf ( "end addGHCclass %s\n", textToStr(ct) );
+# endif
+}
+
+static Void local finishGHCClass(Class nw)
+{
+ List mems;
+ Int line = cclass(nw).line;
+ Int ctr = - length(cclass(nw).members);
+
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
+# endif
+
+ setCurrModule(cclass(nw).mod);
+
+ cclass(nw).level = 0; /* ToDo: 1 + max (map level supers) */
+ cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
+ cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
+ cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
+
+ for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
+ Pair mem = hd(mems); /* (VarId, Type) */
+ Text txt = textOf(fst(mem));
+ Type ty = snd(mem);
+ Name n = findName(txt);
+ if (nonNull(n)) {
+ ERRMSG(cclass(nw).line)
+ "Repeated definition for class method \"%s\"",
+ textToStr(txt)
+ EEND;
+ }
+ n = newName(txt,NIL);
+ name(n).line = cclass(nw).line;
+ name(n).type = ty;
+ name(n).number = ctr++;
+ hd(mems) = n;
+ }
+# ifdef DEBUG_IFACE
+ printf ( "end finishGHCclass %s\n", textToStr(cclass(nw).text) );
+# endif
+}
+
+Void addGHCInstance (line,ctxt0,cls,var)
+Int line;
+List ctxt0; /* [(QConId, Type)] */
+Pair cls; /* (ConId, [Type]) */
+Text var; { /* Text */
+ List tmp, tvs, ks;
+ Inst in = newInst();
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin addGHCInstance\n" );
+# endif
+
+ /* Make tvs into a list of tyvars with bogus kinds. */
+ tvs = nubList(ifTyvarsIn(snd(cls)));
+ ks = NIL;
+ for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
+ hd(tmp) = pair(hd(tmp),STAR);
+ ks = cons(STAR,ks);
+ }
+
+ inst(in).line = line;
+ inst(in).implements = NIL;
+ inst(in).kinds = ks;
+ inst(in).specifics = tvsToOffsets(line,ctxt0,tvs);
+ inst(in).numSpecifics = length(ctxt0);
+ inst(in).head = tvsToOffsets(line,cls,tvs);
+#if 0
+Is this still needed?
+ {
+ Name b = newName(inventText(),NIL);
+ name(b).line = line;
+ name(b).arity = length(ctxt); /* unused? */
+ name(b).number = DFUNNAME;
+ inst(in).builder = b;
+ bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ }
+#endif
+ ghcInstanceDecls = cons(in, ghcInstanceDecls);
+# ifdef DEBUG_IFACE
+ printf ( "end addGHCInstance\n" );
+# endif
+}
+
+static Void local finishGHCInstance(Inst in)
+{
+ Int line = inst(in).line;
+ Cell cl = fst(inst(in).head);
+ Class c;
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin finishGHCInstance\n" );
+# endif
+
+ setCurrModule(inst(in).mod);
+ c = findClass(textOf(cl));
+ if (isNull(c)) {
+ ERRMSG(line) "Unknown class \"%s\" in instance",
+ textToStr(textOf(cl))
+ EEND;
+ }
+ inst(in).head = conidcellsToTycons(line,inst(in).head);
+ inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
+ cclass(c).instances = cons(in,cclass(c).instances);
+# ifdef DEBUG_IFACE
+ printf ( "end finishGHCInstance\n" );
+# endif
+}
+
+/* --------------------------------------------------------------------------
+ * Helper fns
+ * ------------------------------------------------------------------------*/
+
+/* This is called from the addGHC* functions. It traverses a structure
+ and converts varidcells, ie, type variables parsed by the interface
+ parser, into Offsets, which is how Hugs wants to see them internally.
+ The Offset for a type variable is determined by its place in the list
+ passed as the second arg; the associated kinds are irrelevant.
+*/
+static Type local tvsToOffsets(line,type,ktyvars)
+Int line;
+Type type;
+List ktyvars; { /* [(VarId|Text,Kind)] */
+ switch (whatIs(type)) {
+ case NIL:
+ case TUPLE:
+ case QUALIDENT:
+ case CONIDCELL:
+ case TYCON:
+ return type;
+ case AP:
+ return ap( tvsToOffsets(line,fun(type),ktyvars),
+ tvsToOffsets(line,arg(type),ktyvars) );
+ case POLYTYPE:
+ return mkPolyType (
+ polySigOf(type),
+ tvsToOffsets(line,monotypeOf(type),ktyvars)
+ );
+ break;
+ case QUAL:
+ return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
+ tvsToOffsets(line,snd(snd(type)),ktyvars)));
+ case VARIDCELL: /* Ha! some real work to do! */
+ { Int i = 0;
+ Text tv = textOf(type);
+ for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
+ Cell varid = fst(hd(ktyvars));
+ Text tt = isVar(varid) ? textOf(varid) : varid;
+ if (tv == tt) return mkOffset(i);
+ }
+ ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
+ EEND;
+ break;
+ }
+ default:
+ fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
+ print(type,20);
+ fprintf(stderr,"\n");
+ assert(0);
+ }
+ assert(0); /* NOTREACHED */
+}
+
+
+/* This is called from the finishGHC* functions. It traverses a structure
+ and converts conidcells, ie, type constructors parsed by the interface
+ parser, into Tycons (or Classes), which is how Hugs wants to see them
+ internally. Calls to this fn have to be deferred to the second phase
+ of interface loading (finishGHC* rather than addGHC*) so that all relevant
+ Tycons or Classes have been loaded into the symbol tables and can be
+ looked up.
+*/
+static Type local conidcellsToTycons(line,type)
+Int line;
+Type type; {
+ switch (whatIs(type)) {
+ case NIL:
+ case OFFSET:
+ case TYCON:
+ case CLASS:
+ case VARIDCELL:
+ return type;
+ case QUALIDENT:
+ { List t;
+ Text m = qmodOf(type);
+ Text v = qtextOf(type);
+ Module mod = findModule(m);
+printf ( "lookup qualident " ); print(type,100); printf("\n");
+ if (isNull(mod)) {
+ ERRMSG(line)
+ "Undefined module in qualified name \"%s\"",
+ identToStr(type)
+ EEND;
+ return NIL;
+ }
+ for (t=module(mod).tycons; nonNull(t); t=tl(t))
+ if (v == tycon(hd(t)).text) return hd(t);
+ for (t=module(mod).classes; nonNull(t); t=tl(t))
+ if (v == cclass(hd(t)).text) return hd(t);
+ ERRMSG(line)
+ "Undefined qualified class or type \"%s\"",
+ identToStr(type)
+ EEND;
+ return NIL;
+ }
+ case CONIDCELL:
+ { Tycon tc;
+ Class cl;
+ tc = findQualTycon(type);
+ if (nonNull(tc)) return tc;
+ cl = findQualClass(type);
+ if (nonNull(cl)) return cl;
+ ERRMSG(line)
+ "Undefined class or type constructor \"%s\"",
+ identToStr(type)
+ EEND;
+ return NIL;
+ }
+ case AP:
+ return ap( conidcellsToTycons(line,fun(type)),
+ conidcellsToTycons(line,arg(type)) );
+ case POLYTYPE:
+ return mkPolyType (
+ polySigOf(type),
+ conidcellsToTycons(line,monotypeOf(type))
+ );
+ break;
+ case QUAL:
+ return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
+ conidcellsToTycons(line,snd(snd(type)))));
+ default:
+ fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
+ whatIs(type));
+ print(type,20);
+ fprintf(stderr,"\n");
+ assert(0);
+ }
+ assert(0); /* NOTREACHED */
+}
+
+
+/* --------------------------------------------------------------------------
+ * Utilities
+ *
+ * None of these do lookups or require that lookups have been resolved
+ * so they can be performed while reading interfaces.
+ * ------------------------------------------------------------------------*/
+
+static Kinds local tvsToKind(tvs)
+List tvs; { /* [(VarId,Kind)] */
+ List rs;
+ Kinds r = STAR;
+ for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
+ r = ap(snd(hd(rs)),r);
+ }
+ return r;
+}
+
+/* arity of a constructor with this type */
+static Int local arityFromType(type)
+Type type; {
+ Int arity = 0;
+ if (isPolyType(type)) {
+ type = monotypeOf(type);
+ }
+ if (whatIs(type) == QUAL) {
+ type = snd(snd(type));
+ }
+ if (whatIs(type) == EXIST) {
+ type = snd(snd(type));
+ }
+ if (whatIs(type)==RANK2) {
+ type = snd(snd(type));
+ }
+ while (isAp(type) && getHead(type)==typeArrow) {
+ arity++;
+ type = arg(type);
+ }
+ return arity;
+}
+
+
+static List local ifTyvarsIn(type)
+Type type; {
+ List vs = typeVarsIn(type,NIL,NIL);
+ List vs2 = vs;
+ for (; nonNull(vs2); vs2=tl(vs2)) {
+ Cell v = hd(vs2);
+ if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
+ hd(vs2) = textOf(hd(vs2));
+ } else {
+ internal("ifTyvarsIn");
+ }
+ }
+ return vs;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Dynamic loading code (probably shouldn't be here)
+ *
+ * o .hi file explicitly says which .so file to load.
+ * This avoids the need for a 1-to-1 relationship between .hi and .so files.
+ *
+ * ToDo: when doing a :reload, we ought to check the modification date
+ * on the .so file.
+ *
+ * o module handles are unloaded (dlclosed) when we call dropScriptsFrom.
+ *
+ * ToDo: do the same for foreign functions - but with complication that
+ * there may be multiple .so files
+ * ------------------------------------------------------------------------*/
+
+typedef struct { char* name; void* addr; } RtsTabEnt;
+
+/* not really true */
+extern int stg_gc_enter_1;
+extern int stg_chk_1;
+extern int stg_update_PAP;
+extern int __ap_2_upd_info;
+
+RtsTabEnt rtsTab[]
+ = {
+ { "stg_gc_enter_1", &stg_gc_enter_1 },
+ { "stg_chk_1", &stg_chk_1 },
+ { "stg_update_PAP", &stg_update_PAP },
+ { "__ap_2_upd_info", &__ap_2_upd_info },
+ {0,0}
+ };
+
+char* strsuffix ( char* s, char* suffix )
+{
+ int sl = strlen(s);
+ int xl = strlen(suffix);
+ if (xl > sl) return NULL;
+ if (0 == strcmp(s+sl-xl,suffix)) return s+sl-xl;
+ return NULL;
+}
+
+char* lookupObjName ( char* nameT )
+{
+ Text tm;
+ Text tn;
+ Text ts;
+ Name naam;
+ char* nm;
+ char* ty;
+ char* a;
+ Int k;
+ Pair pr;
+
+ if (isupper(((int)(nameT[0])))) {
+ // name defined in a module, eg Mod_xyz_static_closure
+ // Place a zero after the module name, and after
+ // the symbol name proper
+ // --> Mod\0xyz\0static_closure
+ nm = strchr(nameT, '_');
+ if (!nm) internal ( "lookupObjName");
+ *nm = 0;
+ nm++;
+ if ((ty=strsuffix(nm, "_static_closure")))
+ { *ty = 0; ty++; ts = text_static_closure; }
+ else
+ if ((ty=strsuffix(nm, "_static_info" )))
+ { *ty = 0; ty++; ts = text_static_info; }
+ else
+ if ((ty=strsuffix(nm, "_con_info" )))
+ { *ty = 0; ty++; ts = text_con_info; }
+ else
+ if ((ty=strsuffix(nm, "_con_entry" )))
+ { *ty = 0; ty++; ts = text_con_entry; }
+ else
+ if ((ty=strsuffix(nm, "_info" )))
+ { *ty = 0; ty++; ts = text_info; }
+ else
+ if ((ty=strsuffix(nm, "_entry" )))
+ { *ty = 0; ty++; ts = text_entry; }
+ else
+ if ((ty=strsuffix(nm, "_closure" )))
+ { *ty = 0; ty++; ts = text_closure; }
+ else {
+ fprintf(stderr, "lookupObjName: unknown suffix on %s\n", nameT );
+ return NULL;
+ }
+ tm = findText(nameT);
+ tn = findText(nm);
+ //printf ( "\nlooking at mod `%s' var `%s' ext `%s' \n",textToStr(tm),textToStr(tn),textToStr(ts));
+ naam = jrsFindQualName(tm,tn);
+ if (isNull(naam)) goto not_found;
+ pr = cellAssoc ( ts, name(naam).ghc_names );
+ if (isNull(pr)) goto no_info;
+ return ptrOf(snd(pr));
+ }
+ else {
+ // name presumably originating from the RTS
+ a = NULL;
+ for (k = 0; rtsTab[k].name; k++) {
+ if (0==strcmp(nameT,rtsTab[k].name)) {
+ a = rtsTab[k].addr;
+ break;
+ }
+ }
+ if (!a) goto not_found_rts;
+ return a;
+ }
+
+not_found:
+ fprintf ( stderr,
+ "lookupObjName: can't resolve name `%s'\n",
+ nameT );
+ return NULL;
+no_info:
+ fprintf ( stderr,
+ "lookupObjName: no info for name `%s'\n",
+ nameT );
+ return NULL;
+not_found_rts:
+ fprintf ( stderr,
+ "lookupObjName: can't resolve RTS name `%s'\n",
+ nameT );
+ return NULL;
+}
+
+
+/* --------------------------------------------------------------------------
+ * ELF specifics
+ * ------------------------------------------------------------------------*/
+
+#include <elf.h>
+
+static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
+{
+ Int i;
+ char* ehdrC = (char*)objImage;
+ Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
+ Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
+ char* ptr = NULL;
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ if (shdr[i].sh_type == sh_type &&
+ i != ehdr->e_shstrndx) {
+ ptr = ehdrC + shdr[i].sh_offset;
+ break;
+ }
+ }
+ return ptr;
+}
+
+static AsmClosure local findObjectSymbol_elfo ( void* objImage, char* name )
+{
+ Int i, nent, j;
+ Elf32_Shdr* shdr;
+ Elf32_Sym* stab;
+ char* strtab;
+ char* ehdrC = (char*)objImage;
+ Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
+ shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
+
+ strtab = findElfSection ( objImage, SHT_STRTAB );
+ if (!strtab) internal("findObjectSymbol_elfo");
+
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ if (shdr[i].sh_type != SHT_SYMTAB) continue;
+ stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
+ nent = shdr[i].sh_size / sizeof(Elf32_Sym);
+ for (j = 0; j < nent; j++) {
+ if ( strcmp(strtab + stab[j].st_name, name) == 0
+ && ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ) {
+ return ehdrC + stab[j].st_value;
+ }
+ }
+ }
+ return NULL;
+}
+
+static Void local resolveReferencesInObjectModule_elfo( objImage )
+void* objImage; {
+ char symbol[1000]; // ToDo
+ int i, j, k;
+ Elf32_Sym* stab;
+ char* strtab;
+ char* ehdrC = (char*)objImage;
+ Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
+ Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
+ Elf32_Word* targ;
+ // first find "the" symbol table
+ //stab = findElfSection ( objImage, SHT_SYMTAB );
+
+ // also go find the string table
+ strtab = findElfSection ( objImage, SHT_STRTAB );
+
+ if (!stab || !strtab)
+ internal("resolveReferencesInObjectModule_elfo");
+
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ if (shdr[i].sh_type == SHT_REL ) {
+ Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
+ Int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
+ Int target_shndx = shdr[i].sh_info;
+ Int symtab_shndx = shdr[i].sh_link;
+ stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
+ printf ( "relocations for section %d using symtab %d\n", target_shndx, symtab_shndx );
+ for (j = 0; j < nent; j++) {
+ Elf32_Addr offset = rtab[j].r_offset;
+ Elf32_Word info = rtab[j].r_info;
+
+ Elf32_Addr P = ((Elf32_Addr)targ) + offset;
+ Elf32_Word* pP = (Elf32_Word*)P;
+ Elf32_Addr A = *pP;
+ Elf32_Addr S;
+
+ printf ("Rel entry %3d is raw(%6p %6p) ", j, (void*)offset, (void*)info );
+ if (!info) {
+ printf ( " ZERO\n" );
+ S = 0;
+ } else {
+ strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
+ printf ( "`%s' ", symbol );
+ if (symbol[0] == 0) {
+ printf ( "-- ignore?\n" );
+ S = 0;
+ }
+ else {
+ S = (Elf32_Addr)lookupObjName ( symbol );
+ printf ( "resolves to %p\n", (void*)S );
+ }
+ }
+ switch (ELF32_R_TYPE(info)) {
+ case R_386_32: *pP = S + A; break;
+ case R_386_PC32: *pP = S + A - P; break;
+ default: fprintf(stderr,
+ "unhandled ELF relocation type %d\n",
+ ELF32_R_TYPE(info));
+ assert(0);
+ }
+
+ }
+ }
+ else
+ if (shdr[i].sh_type == SHT_RELA) {
+ printf ( "RelA " );
+ }
+ }
+}
+
+static Bool local validateOImage_elfo ( void* imgV, Int size )
+{
+ Elf32_Shdr* shdr;
+ Elf32_Sym* stab;
+ int i, j, nent, nstrtab, nsymtabs;
+ char* sh_strtab;
+ char* strtab;
+
+ char* ehdrC = (char*)imgV;
+ Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
+
+ if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
+ ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
+ ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
+ ehdr->e_ident[EI_MAG3] != ELFMAG3) {
+ printf ( "Not an ELF header\n" );
+ return FALSE;
+ }
+ printf ( "Is an ELF header\n" );
+
+ if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
+ printf ( "Not 32 bit ELF\n" );
+ return FALSE;
+ }
+ printf ( "Is 32 bit ELF\n" );
+
+ if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
+ printf ( "Is little-endian\n" );
+ } else
+ if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
+ printf ( "Is big-endian\n" );
+ } else {
+ printf ( "Unknown endiannness\n" );
+ return FALSE;
+ }
+
+ if (ehdr->e_type != ET_REL) {
+ printf ( "Not a relocatable object (.o) file\n" );
+ return FALSE;
+ }
+ printf ( "Is a relocatable object (.o) file\n" );
+
+ printf ( "Architecture is " );
+ switch (ehdr->e_machine) {
+ case EM_386: printf ( "x86\n" ); break;
+ case EM_SPARC: printf ( "sparc\n" ); break;
+ default: printf ( "unknown\n" ); return FALSE;
+ }
+
+ printf ( "\nSection header table: start %d, n_entries %d, ent_size %d\n",
+ ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
+
+ assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
+
+ shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
+
+ if (ehdr->e_shstrndx == SHN_UNDEF) {
+ printf ( "No section header string table\n" );
+ sh_strtab = NULL;
+ } else {
+ printf ( "Section header string table is section %d\n",
+ ehdr->e_shstrndx);
+ sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
+ }
+
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ printf ( "%2d: ", i );
+ printf ( "type=%2d ", shdr[i].sh_type );
+ printf ( "size=%4d ", shdr[i].sh_size );
+ if (shdr[i].sh_type == SHT_REL ) printf ( "Rel " ); else
+ if (shdr[i].sh_type == SHT_RELA) printf ( "RelA " ); else
+ printf ( " " );
+ if (sh_strtab) printf ( "sname=%s", sh_strtab + shdr[i].sh_name );
+ printf ( "\n" );
+ }
+
+ printf ( "\n\nString tables\n" );
+ strtab = NULL;
+ nstrtab = 0;
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ if (shdr[i].sh_type == SHT_STRTAB &&
+ i != ehdr->e_shstrndx) {
+ printf ( " section %d is a normal string table\n", i );
+ strtab = ehdrC + shdr[i].sh_offset;
+ nstrtab++;
+ }
+ }
+ if (nstrtab != 1)
+ printf ( "WARNING: no string tables, or too many\n" );
+
+ nsymtabs = 0;
+ printf ( "\n\nSymbol tables\n" );
+ for (i = 0; i < ehdr->e_shnum; i++) {
+ if (shdr[i].sh_type != SHT_SYMTAB) continue;
+ printf ( "section %d is a symbol table\n", i );
+ nsymtabs++;
+ stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
+ nent = shdr[i].sh_size / sizeof(Elf32_Sym);
+ printf ( " number of entries is apparently %d (%d rem)\n",
+ nent,
+ shdr[i].sh_size % sizeof(Elf32_Sym)
+ );
+ if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
+ printf ( "non-integral number of symbol table entries\n");
+ return FALSE;
+ }
+ for (j = 0; j < nent; j++) {
+ printf ( " %2d ", j );
+ printf ( " sec=%-5d size=%-3d val=%-5p ",
+ (int)stab[j].st_shndx,
+ (int)stab[j].st_size,
+ (char*)stab[j].st_value );
+
+ printf ( "type=" );
+ switch (ELF32_ST_TYPE(stab[j].st_info)) {
+ case STT_NOTYPE: printf ( "notype " ); break;
+ case STT_OBJECT: printf ( "object " ); break;
+ case STT_FUNC : printf ( "func " ); break;
+ case STT_SECTION: printf ( "section" ); break;
+ case STT_FILE: printf ( "file " ); break;
+ default: printf ( "? " ); break;
+ }
+ printf ( " " );
+
+ printf ( "bind=" );
+ switch (ELF32_ST_BIND(stab[j].st_info)) {
+ case STB_LOCAL : printf ( "local " ); break;
+ case STB_GLOBAL: printf ( "global" ); break;
+ case STB_WEAK : printf ( "weak " ); break;
+ default: printf ( "? " ); break;
+ }
+ printf ( " " );
+
+ printf ( "name=%s\n", strtab + stab[j].st_name );
+ }
+ }
+
+ if (nsymtabs == 0) {
+ printf ( "Didn't find any symbol tables\n" );
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Generic lookups
+ * ------------------------------------------------------------------------*/
+
+static Void local bindGHCNameTo ( Name n, Text suffix )
+{
+ char symbol[1000]; /* ToDo: arbitrary constants must die */
+ AsmClosure res;
+ sprintf(symbol,"%s_%s_%s",
+ textToStr(module(currentModule).text),
+ textToStr(name(n).text),textToStr(suffix));
+ // fprintf(stderr, "\nbindGHCNameTo %s ", symbol);
+ res = findObjectSymbol_elfo ( module(currentModule).oImage, symbol );
+ if (!res) {
+ ERRMSG(0) "Can't find symbol \"%s\" in object for module \"%s\"",
+ symbol,
+ textToStr(module(currentModule).text)
+ EEND;
+ }
+ //fprintf(stderr, " = %p\n", res );
+ name(n).ghc_names = cons(pair(suffix,mkPtr(res)), name(n).ghc_names);
+
+ // set the stgVar to be a CPTRCELL to the closure label.
+ // prefer dynamic over static closures if given a choice
+ if (suffix == text_closure || suffix == text_static_closure) {
+ if (isNull(name(n).stgVar)) {
+ // accept any old thing
+ name(n).stgVar = mkCPtr(res);
+ } else {
+ // only accept something more dynamic that what we have now
+ if (suffix != text_static_closure
+ && isCPtr(name(n).stgVar)
+ && cptrOf(name(n).stgVar) != res)
+ name(n).stgVar = mkCPtr(res);
+ }
+ }
+}
+
+static Void local resolveReferencesInObjectModule ( Module m )
+{
+fprintf(stderr, "resolveReferencesInObjectModule %s\n",textToStr(module(m).text));
+ resolveReferencesInObjectModule_elfo ( module(m).oImage );
+}
+
+static Bool local validateOImage(img,size)
+void* img;
+Int size; {
+ return validateOImage_elfo ( img, size );
+}
+
+
+/* --------------------------------------------------------------------------
+ * Control:
+ * ------------------------------------------------------------------------*/
+
+Void interface(what)
+Int what; {
+ switch (what) {
+ case INSTALL:
+ case RESET:
+ ifImports = NIL;
+ ghcVarDecls = NIL;
+ ghcConstrDecls = NIL;
+ ghcSynonymDecls = NIL;
+ ghcClassDecls = NIL;
+ ghcInstanceDecls = NIL;
+ ghcExports = NIL;
+ ghcImports = NIL;
+ ghcModules = NIL;
+ text_info = findText("info");
+ text_entry = findText("entry");
+ text_closure = findText("closure");
+ text_static_closure = findText("static_closure");
+ text_static_info = findText("static_info");
+ text_con_info = findText("con_info");
+ text_con_entry = findText("con_entry");
+ break;
+ case MARK:
+ mark(ifImports);
+ mark(ghcVarDecls);
+ mark(ghcConstrDecls);
+ mark(ghcSynonymDecls);
+ mark(ghcClassDecls);
+ mark(ghcInstanceDecls);
+ mark(ghcImports);
+ mark(ghcExports);
+ mark(ghcModules);
+ break;
+ }
+}
+
+/*-------------------------------------------------------------------------*/
diff --git a/ghc/interpreter/link.h b/ghc/interpreter/link.h
index 6caf0e448dbb7b5e4a311274d27a14da808b262e..b87a0e7b25c1ed0e81819b6ba520bc69217f52f8 100644
--- a/ghc/interpreter/link.h
+++ b/ghc/interpreter/link.h
@@ -130,3 +130,5 @@ extern Cell predFractional;; /* Fractional (mkOffset(0))
extern Cell predIntegral;; /* Integral (mkOffset(0)) */
extern Kind starToStar;; /* Type -> Type */
extern Cell predMonad;; /* Monad (mkOffset(0)) */
+
+
diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c
index ebdf4bb28fe1194b841e343a13d07280a938544b..2847b4141e4d560353d64455666868bad15ab5b0 100644
--- a/ghc/interpreter/machdep.c
+++ b/ghc/interpreter/machdep.c
@@ -12,8 +12,8 @@
* in the distribution for details.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/04/27 10:06:55 $
+ * $Revision: 1.6 $
+ * $Date: 1999/06/07 17:22:37 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
@@ -133,14 +133,16 @@ static String local readRegChildStrings Args((HKEY, String, String, Char, String
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 timeChanged(now,thn) (now!=thn)
+#define timeSet(var,tm) var = tm
+#define timeEarlier(earlier,now) (earlier < now)
#endif
-static Void local getFileInfo Args((String, Time *, Long *));
static Bool local readable Args((String));
+static Void local getFileInfo Args((String, Time *, Long *));
static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
String f;
@@ -149,10 +151,10 @@ Long *sz; {
#if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
struct stat scbuf;
if (!stat(f,&scbuf)) {
- *tm = scbuf.st_mtime;
+ if (tm) *tm = scbuf.st_mtime;
*sz = (Long)(scbuf.st_size);
} else {
- *tm = 0;
+ if (tm) *tm = 0;
*sz = 0;
}
#else /* normally just use stat() */
@@ -161,15 +163,20 @@ Long *sz; {
r.r[1] = (int)s;
os_swi(OS_File, &r);
if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
- tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
- tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
+ if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
+ if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
} else { /* Not found, or not time-stamped */
- tm->hi = tm->lo = 0;
+ if (tm) tm->hi = tm->lo = 0;
}
*sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
#endif
}
+Void getFileSize ( String f, Long* sz )
+{
+ getFileInfo ( f, NULL, sz );
+}
+
#if defined HAVE_GETFINFO /* Mac971031 */
/* --------------------------------------------------------------------------
* Define a MacOS version of access():
@@ -210,6 +217,7 @@ String f; {
return (0 == access(f,4));
#elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
struct stat scbuf;
+ //fprintf(stderr, "readable: %s\n", f );
return ( !stat(f,&scbuf)
&& (scbuf.st_mode & S_IREAD) /* readable */
&& (scbuf.st_mode & S_IFREG) /* regular file */
@@ -255,7 +263,7 @@ static Bool local tryEndings Args((String));
# define SLASH '/'
# define isSLASH(c) ((c)==SLASH)
# define PATHSEP ':'
-# define DLL_ENDING ".so"
+# define DLL_ENDING ".o"
#endif
static String local hugsdir() { /* directory containing lib/Prelude.hs */
@@ -367,9 +375,9 @@ String s; { /* a pathname in some appropriate manner. */
}
#if HSCRIPT
-static String endings[] = { "", ".hs", ".lhs", ".hsx", ".hash", 0 };
+static String endings[] = { "", ".hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
#else
-static String endings[] = { "", ".hs", ".lhs", 0 };
+static String endings[] = { "", ".hi", ".hs", ".lhs", 0 };
#endif
static char searchBuf[FILENAME_MAX+1];
static Int searchPos;
@@ -413,9 +421,9 @@ String s; {
searches the base directory and its direct subdirectories for a file
input: searchbuf contains SLASH terminated base directory
- argument s contains the (base) filename
+ argument s contains the (base) filename
output: TRUE: searchBuf contains the full filename
- FALSE: searchBuf is garbage, file not found
+ FALSE: searchBuf is garbage, file not found
*/
@@ -587,6 +595,124 @@ String path; {
return (tryEndings(nm) ? normPath(searchBuf) : 0);
}
+/* --------------------------------------------------------------------------
+ * New path handling stuff for the Combined System (tm)
+ * ------------------------------------------------------------------------*/
+
+Bool findFilesForModule (
+ String modName,
+ String* path,
+ String* sExt,
+ Bool* sAvail, Time* sTime, Long* sSize,
+ Bool* iAvail, Time* iTime, Long* iSize,
+ Bool* oAvail, Time* oTime, Long* oSize
+ )
+{
+ /* Let the module name given be M.
+ For each path entry P,
+ a s(rc) file will be P/M.hs or P/M.lhs
+ an i(nterface) file will be P/M.hi
+ an o(bject) file will be P/M.o
+ If there is a s file or (both i and o files)
+ use P to fill in the path names.
+ Otherwise, move on to the next path entry.
+ If all path entries are exhausted, return False.
+ */
+ Int nPath;
+ Bool literate;
+ String peStart, peEnd;
+ String augdPath; /* . and then hugsPath */
+
+ *path = *sExt = NULL;
+ *sAvail = *iAvail = *oAvail = FALSE;
+ *sSize = *iSize = *oSize = 0;
+
+ augdPath = malloc(3+strlen(hugsPath));
+ if (!augdPath)
+ internal("moduleNameToFileNames: malloc failed(2)");
+ augdPath[0] = '.';
+ augdPath[1] = PATHSEP;
+ augdPath[2] = 0;
+ strcat(augdPath,hugsPath);
+
+ peEnd = augdPath-1;
+ while (1) {
+ /* Advance peStart and peEnd very paranoically, giving up at
+ the first sign of mutancy in the path string.
+ */
+ if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
+ peStart = peEnd+1;
+ peEnd = peStart;
+ while (*peEnd && *peEnd != PATHSEP) peEnd++;
+
+ /* Now peStart .. peEnd-1 bracket the next path element. */
+ nPath = peEnd-peStart;
+ if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
+ ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
+ hugsPath
+ EEND;
+ free(augdPath);
+ return FALSE;
+ }
+
+ strncpy(searchBuf, peStart, nPath);
+ searchBuf[nPath] = 0;
+ if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
+ searchBuf[nPath++] = SLASH;
+
+ strcpy(searchBuf+nPath, modName);
+ nPath += strlen(modName);
+
+ /* searchBuf now holds 'P/M'. Try out the various endings. */
+ *path = *sExt = NULL;
+ *sAvail = *iAvail = *oAvail = FALSE;
+ *sSize = *iSize = *oSize = 0;
+
+ strcpy(searchBuf+nPath, DLL_ENDING);
+ if (readable(searchBuf)) {
+ *oAvail = TRUE;
+ getFileInfo(searchBuf, oTime, oSize);
+ }
+
+ strcpy(searchBuf+nPath, ".hi");
+ if (readable(searchBuf)) {
+ *iAvail = TRUE;
+ getFileInfo(searchBuf, iTime, iSize);
+ }
+
+ strcpy(searchBuf+nPath, ".hs");
+ if (readable(searchBuf)) {
+ *sAvail = TRUE;
+ literate = FALSE;
+ getFileInfo(searchBuf, sTime, sSize);
+ *sExt = ".hs";
+ } else {
+ strcpy(searchBuf+nPath, ".lhs");
+ if (readable(searchBuf)) {
+ *sAvail = TRUE;
+ literate = TRUE;
+ getFileInfo(searchBuf, sTime, sSize);
+ *sExt = ".lhs";
+ }
+ }
+
+ /* Success? */
+ if (*sAvail || (*oAvail && *iAvail)) {
+ nPath -= strlen(modName);
+ *path = malloc(nPath+1);
+ if (!(*path))
+ internal("moduleNameToFileNames: malloc failed(1)");
+ strncpy(*path, searchBuf, nPath);
+ (*path)[nPath] = 0;
+ free(augdPath);
+ return TRUE;
+ }
+
+ }
+
+}
+
+
/* --------------------------------------------------------------------------
* Substitute old value of path into empty entries in new path
* eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y
index 60e565c6e8a3ec66c0fb510fe72a00d994e1e29d..c746368b9d03696bf60e9b8f316cc47545b4c615 100644
--- a/ghc/interpreter/parser.y
+++ b/ghc/interpreter/parser.y
@@ -11,8 +11,8 @@
* in the distribution for details.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.5 $
- * $Date: 1999/04/27 10:06:58 $
+ * $Revision: 1.6 $
+ * $Date: 1999/06/07 17:22:41 $
* ------------------------------------------------------------------------*/
%{
@@ -28,7 +28,8 @@
#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 exportSelf() singleton(ap(MODULEENT, \
+ mkCon(module(currentModule).text)))
#define yyerror(s) /* errors handled elsewhere */
#define YYSTYPE Cell
@@ -36,6 +37,7 @@ static Cell local gcShadow Args((Int,Cell));
static Void local syntaxError Args((String));
static String local unexpected Args((Void));
static Cell local checkPrec Args((Cell));
+static Void local fixDefn Args((Syntax,Cell,Cell,List));
static Cell local buildTuple Args((List));
static List local checkContext Args((List));
static Cell local checkPred Args((Cell));
@@ -87,17 +89,295 @@ static Void local noTREX Args((String));
%token '!' IMPLIES '(' ',' ')'
%token '[' ';' ']' '`' '.'
%token TMODULE IMPORT HIDING QUALIFIED ASMOD
-%token EXPORT UNSAFE
+%token EXPORT INTERFACE REQUIRES UNSAFE INSTIMPORT
%%
/*- Top level script/module structure -------------------------------------*/
start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
| SCRIPT topModule {valDefns = $2; sp-=1;}
+ | INTERFACE iface {sp-=1;}
| error {syntaxError("input");}
;
+
+/*- GHC interface file parsing: -------------------------------------------*/
+
+/* Reading in an interface file is surprisingly like reading
+ * a normal Haskell module: we read in a bunch of declarations,
+ * construct symbol table entries, etc. The "only" differences
+ * are that there's no syntactic sugar to deal with and we don't
+ * have to read in expressions.
+ */
+
+/*- Top-level interface files -----------------------------*/
+iface : INTERFACE ifName NUMLIT checkVersion WHERE ifDecls
+ {$$ = gc6(NIL); }
+ | INTERFACE error {syntaxError("interface file");}
+ ;
+ifDecls: {$$=gc0(NIL);}
+ | ifDecl ';' ifDecls {$$=gc3(cons($1,$3));}
+ ;
+varid_or_conid
+ : VARID { $$=gc1($1); }
+ | CONID { $$=gc1($1); }
+ ;
+opt_bang : '!' {$$=gc1(NIL);}
+ | {$$=gc0(NIL);}
+ ;
+ifName : CONID {openGHCIface(textOf($1));
+ $$ = gc1(NIL);}
+checkVersion
+ : NUMLIT {$$ = gc1(NIL); }
+ ;
+ifDecl
+ : IMPORT CONID opt_bang NUMLIT COCO version_list_junk
+ { addGHCImports(intOf($4),textOf($2),
+ $6);
+ $$ = gc6(NIL);
+ }
+
+ | INSTIMPORT CONID {$$=gc2(NIL);}
+
+ | EXPORT CONID ifEntities { addGHCExports($2,$3);
+ $$=gc3(NIL);}
+
+ | NUMLIT INFIXL optDigit varid_or_conid
+ {$$ = gc4(fixdecl($2,singleton($4),
+ LEFT_ASS,$3)); }
+ | NUMLIT INFIXR optDigit varid_or_conid
+ {$$ = gc4(fixdecl($2,singleton($4),
+ RIGHT_ASS,$3)); }
+ | NUMLIT INFIXN optDigit varid_or_conid
+ {$$ = gc4(fixdecl($2,singleton($4),
+ NON_ASS,$3)); }
+
+ | TINSTANCE ifCtxInst ifInstHd '=' ifVar
+ { addGHCInstance(intOf($1),$2,$3,
+ textOf($5));
+ $$ = gc5(NIL); }
+ | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
+ { addGHCSynonym(intOf($2),$3,$4,$6);
+ $$ = gc6(NIL); }
+
+ | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
+ { addGHCDataDecl(intOf($2),
+ $3,$4,$5,$6);
+ $$ = gc6(NIL); }
+
+ | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
+ { addGHCNewType(intOf($2),
+ $3,$4,$5,$6);
+ $$ = gc6(NIL); }
+ | NUMLIT TCLASS ifCtxDecl ifCon ifTyvar ifCmeths
+ { addGHCClass(intOf($2),$3,$4,$5,$6);
+ $$ = gc6(NIL); }
+ | NUMLIT ifVar COCO ifType
+ { addGHCVar(intOf($3),textOf($2),$4);
+ $$ = gc4(NIL); }
+ | error { syntaxError(
+ "interface declaration"); }
+ ;
+
+
+/*- Interface variable and constructor ids ----------------*/
+ifTyvar : VARID {$$ = $1;}
+ ;
+ifVar : VARID {$$ = gc1($1);}
+ ;
+ifCon : CONID {$$ = gc1($1);}
+ ;
+ifQCon : CONID {$$ = gc1($1);}
+ | QCONID {$$ = gc1($1);}
+ ;
+ifConData : ifCon {$$ = gc1($1);}
+ | '(' ')' {$$ = gc2(typeUnit);}
+ | '[' ']' {$$ = gc2(typeList);}
+ | '(' ARROW ')' {$$ = gc3(typeArrow);}
+ ;
+ifTCName : CONID { $$ = gc1($1); }
+ | CONOP { $$ = gc1($1); }
+ | '(' ARROW ')' { $$ = gc3(typeArrow); }
+ | '[' ']' { $$ = gc1(typeList); }
+ ;
+ifQTCName : ifTCName { $$ = gc1($1); }
+ | QCONID { $$ = gc1($1); }
+ | QCONOP { $$ = gc1($1); }
+ ;
+
+
+/*- Interface contexts ------------------------------------*/
+ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} => */
+ /* :: [(QConId, VarId)] */
+ : ALL ifForall ifCtxDecl {$$=gc3($3);}
+ | ALL ifForall IMPLIES {$$=gc3(NIL);}
+ | {$$=gc0(NIL);}
+ ;
+ifInstHd /* { Class aType } :: (ConId, Type) */
+ : '{' ifCon ifAType '}' {$$=gc4(pair($2,$3));}
+ ;
+
+ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
+ : { $$ = gc0(NIL); }
+ | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); }
+ ;
+ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
+ : { $$ = gc0(NIL); }
+ | '{' ifCtxDeclL '}' { $$ = gc3($2); }
+ ;
+ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
+ : ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));}
+ | ifCtxDeclLE {$$=gc1(cons($1,NIL));}
+ | {$$=gc0(NIL);}
+ ;
+ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
+ : ifQCon ifTyvar {$$=gc2(pair($1,$2));}
+ ;
+
+
+/*- Interface data declarations - constructor lists -------*/
+ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text)],NIL)] */
+ : {$$ = gc0(NIL);}
+ | '=' ifConstrL {$$ = gc2($2);}
+ ;
+ifConstrL /* [(ConId,[(Type,Text)],NIL)] */
+ : ifConstr {$$ = gc1(singleton($1));}
+ | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
+ ;
+ifConstr /* (ConId,[(Type,Text)],NIL) */
+ : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));}
+ | ifConData '{' ifDataNamedFieldL '}'
+ {$$ = gc4(triple($1,$3,NIL));}
+ ;
+ifDataAnonFieldL /* [(Type,Text)] */
+ : {$$=gc0(NIL);}
+ | ifDataAnonField ifDataAnonFieldL
+ {$$=gc2(cons($1,$2));}
+ ;
+ifDataNamedFieldL /* [(Type,Text)] */
+ : {$$=gc0(NIL);}
+ | ifDataNamedField {$$=gc1(cons($1,NIL));}
+ | ifDataNamedField ',' ifDataNamedFieldL
+ {$$=gc3(cons($1,$3));}
+ ;
+ifDataAnonField /* (Type,Text) */
+ : ifAType {$$=gc1(pair($1,NIL));}
+ ;
+ifDataNamedField /* (Type,Text) */
+ : VARID COCO ifAType {$$=gc3(pair($3,$1));}
+ ;
+
+
+/*- Interface class declarations - methods ----------------*/
+ifCmeths /* [(VarId,Type)] */
+ : { $$ = gc0(NIL); }
+ | WHERE '{' ifCmethL '}' { $$ = gc4($3); }
+ ;
+ifCmethL /* [(VarId,Type)] */
+ : ifCmeth { $$ = gc1(singleton($1)); }
+ | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
+ ;
+ifCmeth /* (VarId,Type) */
+ : ifVar COCO ifType { $$ = gc3(pair($1,$3)); }
+ | ifVar '=' COCO ifType { $$ = gc4(pair($1,$4)); }
+ /* has default method */
+ ;
+
+
+/*- Interface newtype declararions ------------------------*/
+ifNewTypeConstr /* (ConId,Type) */
+ : '=' ifCon ifAType { $$ = gc3(pair($2,$3)); }
+ ;
+
+
+/*- Interface type expressions ----------------------------*/
+ifType : ALL ifForall ifCtxDeclT IMPLIES ifType
+ { if ($3 == NIL)
+ $$=gc5($5); else
+ $$=gc5(pair(QUAL,pair($3,$5)));
+ }
+ | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); }
+ | ifBType { $$ = gc1($1); }
+ ;
+ifForall /* [(VarId,Kind)] */
+ : '[' ifKindedTyvarL ']' { $$ = gc3($2); }
+ ;
+ifTypes2 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); }
+ | ifType ',' ifTypes2 { $$ = gc3(cons($1,$3)); }
+ ;
+ifBType : ifAType { $$ = gc1($1); }
+ | ifBType ifAType { $$ = gc2(ap($1,$2)); }
+ ;
+ifAType : ifQTCName { $$ = gc1($1); }
+ | ifTyvar { $$ = gc1($1); }
+ | '(' ')' { $$ = gc2(typeUnit); }
+ | '(' ifTypes2 ')' { $$ = gc3(buildTuple($2)); }
+ | '[' ifType ']' { $$ = gc3(ap(typeList,$2));}
+ | '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP,
+ pair($2,$3))); }
+ | '(' ifType ')' { $$ = gc3($2); }
+ ;
+ifATypes : { $$ = gc0(NIL); }
+ | ifAType ifATypes { $$ = gc2(cons($1,$2)); }
+ ;
+
+
+/*- Interface kinds ---------------------------------------*/
+ifKindedTyvarL /* [(VarId,Kind)] */
+ : { $$ = gc0(NIL); }
+ | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
+ ;
+ifKindedTyvar /* (VarId,Kind) */
+ : ifTyvar { $$ = gc1(pair($1,STAR)); }
+ | ifTyvar COCO ifAKind { $$ = gc3(pair($1,$3)); }
+ ;
+ifKind : ifAKind { $$ = gc1($1); }
+ | ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); }
+ ;
+ifAKind : VAROP { $$ = gc1(STAR); }
+ /* should be '*' */
+ | '(' ifKind ')' { $$ = gc3($2); }
+ ;
+
+
+/*- Interface version/export/import stuff -----------------*/
+ifEntities
+ : { $$ = gc0(NIL); }
+ | ifEntity ifEntities { $$ = gc2(cons($1,$2)); }
+ ;
+ifEntity
+ : ifEntityOcc {$$=gc1($1);}
+ | ifEntityOcc ifStuffInside {$$=gc2($1);}
+ | ifEntityOcc '|' ifStuffInside {$$=gc3($1);}
+ /* exporting datacons but not tycon */
+ ;
+ifEntityOcc
+ : ifVar { $$ = gc1($1); }
+ | ifCon { $$ = gc1($1); }
+ | ARROW { $$ = gc1(typeArrow); }
+ | '(' ARROW ')' { $$ = gc3(typeArrow); }
+ /* why allow both? */
+ ;
+ifStuffInside
+ : '{' ifValOccs '}' { $$ = gc3($2); }
+ ;
+ifValOccs
+ : ifValOcc { $$ = gc1(singleton($1)); }
+ | ifValOcc ifValOccs { $$ = gc2(cons($1,$2)); }
+ ;
+ifValOcc
+ : ifVar {$$ = gc1($1); }
+ | ifCon {$$ = gc1($1); }
+ ;
+version_list_junk
+ : {$$=gc0(NIL);}
+ | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
+ | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
+ ;
+
+
/*- 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.
@@ -108,7 +388,10 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
* We use the 1.2 header because it breaks much less pre-module code.
*/
topModule : startMain begin modBody end {
- setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
+ setExportList(singleton(
+ ap(MODULEENT,
+ mkCon(module(currentModule).text)
+ )));
$$ = gc3($3);
}
| TMODULE modname expspec WHERE '{' modBody end
@@ -126,8 +409,11 @@ 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 */
+ String modName
+ = findPathname(scriptFile,
+ textToStr(textOf($1)));
+ if (modName) {
+ /* fillin pathname if known */
$$ = mkStr(findText(modName));
} else {
$$ = $1;
@@ -252,7 +538,7 @@ topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);}
| TYPE error {syntaxError("type definition");}
| DATA btype2 '=' constrs deriving
{defTycon(5,$3,checkTyLhs($2),
- ap(rev($4),$5),DATATYPE);}
+ ap(rev($4),$5),DATATYPE);}
| DATA context IMPLIES tyLhs '=' constrs deriving
{defTycon(7,$5,$4,
ap(qualify($2,rev($6)),
@@ -280,7 +566,7 @@ invars : invars ',' invar {$$ = gc3(cons($3,$1));}
| invar {$$ = gc1(cons($1,NIL));}
;
invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
- $3));}
+ $3));}
| var {$$ = $1;}
;
constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
@@ -880,12 +1166,13 @@ varid1 : VARID {$$ = gc1($1);}
/*- Tricks to force insertion of leading and closing braces ---------------*/
-begin : error {yyerrok; goOffside(startColumn);}
+begin : error {yyerrok;
+ if (offsideON) goOffside(startColumn);}
;
/* deal with trailing semicolon */
end : '}' {$$ = $1;}
| error {yyerrok;
- if (canUnOffside()) {
+ if (offsideON && canUnOffside()) {
unOffside();
/* insert extra token on stack*/
push(NIL);
@@ -910,7 +1197,7 @@ Cell e; {
* x1 | ... | xn | la ===> e | la
* top() top()
*
- * Othwerwise, the transformation is:
+ * Otherwise, the transformation is:
* pushed: n-1 0 0
* x1 | ... | xn ===> e
* top() top()
@@ -962,7 +1249,7 @@ static String local unexpected() { /* find name for unexpected token */
case DEFAULT : keyword("default");
case IMPORT : keyword("import");
case TMODULE : keyword("module");
- case ALL : keyword("forall");
+ case ALL : keyword("__forall");
#undef keyword
case ARROW : return "`->'";
diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c
index 7b0e6011d9923c7e7fcaa0c92d2e79c4c746a238..09593821138c282be1b10e6f143b930454ad50c9 100644
--- a/ghc/interpreter/static.c
+++ b/ghc/interpreter/static.c
@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: static.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:07:01 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:35 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -65,7 +65,6 @@ static List local classBindings Args((String,Class,List));
static Name local memberName Args((Class,Text));
static List local numInsert Args((Int,Cell,List));
-static List local typeVarsIn Args((Cell,List,List));
static List local maybeAppendVar Args((Cell,List));
static Type local checkSigType Args((Int,String,Cell,Type));
@@ -1588,7 +1587,7 @@ List xs; {
* occur in the type expression when read from left to right.
* ------------------------------------------------------------------------*/
-static List local typeVarsIn(ty,us,vs) /* Calculate list of type variables*/
+List typeVarsIn(ty,us,vs) /* Calculate list of type variables*/
Cell ty; /* used in type expression, reading*/
List us; /* from left to right ignoring any */
List vs; { /* listed in us. */
diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index 7495377ad377c871dd3022e7296bd8c3327ba6ce..3d62bc568bbf8726fc0e773d2bb71b3466230984 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:07:05 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:49 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -415,6 +415,7 @@ Cell parent; {
name(nameHw).type = NIL;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
+ name(nameHw).ghc_names = NIL;
module(currentModule).names=cons(nameHw,module(currentModule).names);
name(nameHw).nextNameHash = nameHash[h];
nameHash[h] = nameHw;
@@ -443,8 +444,11 @@ Name nm; { /* no clash is caused */
static Void local hashName(nm) /* Insert Name into hash table */
Name nm; {
- Text t = name(nm).text;
- Int h = nHash(t);
+ Text t;
+ Int h;
+ assert(isName(nm));
+ t = name(nm).text;
+ h = nHash(t);
name(nm).nextNameHash = nameHash[h];
nameHash[h] = nm;
}
@@ -500,6 +504,7 @@ Name nameFromStgVar ( StgVar v )
return NIL;
}
+
/* --------------------------------------------------------------------------
* Primitive functions:
* ------------------------------------------------------------------------*/
@@ -743,6 +748,7 @@ Inst newInst() { /* Add new instance to table */
inst(instHw).specifics = NIL;
inst(instHw).implements = NIL;
inst(instHw).builder = NIL;
+ inst(instHw).mod = currentModule;
return instHw++;
}
@@ -874,10 +880,24 @@ Text t; {
module(moduleHw).tycons = NIL;
module(moduleHw).names = NIL;
module(moduleHw).classes = NIL;
- module(moduleHw).objectFile = 0;
+ module(moduleHw).oImage = NULL;
return moduleHw++;
}
+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)
+ );
+ printf ( "end MODULES\n" );
+ fflush(stderr); fflush(stdout);
+}
+
+
Module findModule(t) /* locate Module in module table */
Text t; {
Module m;
@@ -903,6 +923,7 @@ Cell c; {
static local Module findQualifier(t) /* locate Module in import list */
Text t; {
Module ms;
+printf ( "findQualifier %s\n", textToStr(t));
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
@@ -929,6 +950,21 @@ Module m; {
}
}
+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 (ns = module(m).names; nonNull(ns); ns=tl(ns))
+ if (name(hd(ns)).text == sn) return hd(ns);
+
+ return NIL;
+}
+
/* --------------------------------------------------------------------------
* Script file storage:
*
@@ -965,6 +1001,25 @@ Int val, mx; {
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) {
@@ -1537,6 +1592,10 @@ Int depth; {
Printf("Polytype");
print(snd(c),depth-1);
break;
+ case QUAL:
+ Printf("Qualtype");
+ print(snd(c),depth-1);
+ break;
case RANK2:
Printf("Rank2(");
if (isPair(snd(c)) && isInt(fst(snd(c)))) {
@@ -1755,6 +1814,22 @@ Cell c;
x.i = snd(c);
return x.p;
}
+Cell mkCPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(CPTRCELL,x.i);
+}
+
+Ptr cptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(fst(c) == CPTRCELL);
+ x.i = snd(c);
+ return x.p;
+}
#elif SIZEOF_INTP == 2*SIZEOF_INT
typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
Cell mkPtr(p)
@@ -1969,7 +2044,7 @@ List xs; {
return ys;
}
-List splitAt(n,xs) /* drop n things from front of list*/
+List splitAt(n,xs) /* drop n things from front of list*/
Int n;
List xs; {
for(; n>0; --n) {
@@ -1978,7 +2053,7 @@ List xs; {
return xs;
}
-Cell nth(n,xs) /* extract n'th element of list */
+Cell nth(n,xs) /* extract n'th element of list */
Int n;
List xs; {
for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
@@ -2007,6 +2082,16 @@ List xs; {
return xs; /* here if element not found */
}
+List nubList(xs) /* nuke dups in list */
+List xs; { /* non destructive */
+ List outs = NIL;
+ for (; nonNull(xs); xs=tl(xs))
+ if (isNull(cellIsMember(hd(xs),outs)))
+ outs = cons(hd(xs),outs);
+ outs = rev(outs);
+ return outs;
+}
+
/* --------------------------------------------------------------------------
* Operations on applications:
* ------------------------------------------------------------------------*/
@@ -2188,6 +2273,7 @@ Int what; {
mark(name(i).defn);
mark(name(i).stgVar);
mark(name(i).type);
+ mark(name(i).ghc_names);
}
end("Names", nameHw-NAMEMIN);
diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 7cb8c411c557ffcc3532bb4b813103ca57777a19..861bb82b6acdbd5720fed2900b2dcdaa2dc957f6 100644
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -9,8 +9,8 @@
* in the distribution for details.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:07:06 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:47 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
@@ -150,12 +150,33 @@ extern Cell whatIs Args((Cell));
#define BIGCELL 16 /* Integer literal: snd :: Text */
#if PTR_ON_HEAP
#define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
+#define CPTRCELL 18 /* Native code pointer snd :: Ptr */
#endif
#if TREX
-#define EXTCOPY 18 /* Copy of an Ext: snd :: Text */
+#define EXTCOPY 19 /* Copy of an Ext: snd :: Text */
+#endif
+
+//#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
+
+#if 1
+static Text textOf( Cell c )
+{
+ Bool ok =
+ (whatIs(c)==VARIDCELL
+ || whatIs(c)==CONIDCELL
+ || whatIs(c)==VAROPCELL
+ || whatIs(c)==CONOPCELL
+ || whatIs(c)==STRCELL
+ || whatIs(c)==DICTVAR
+ );
+ if (!ok) {
+fprintf(stderr, "\ntextOf -- tag %d\n",whatIs(c) );
+ assert(ok);
+ }
+ return snd(c);
+}
#endif
-#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
#define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
#define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
#define mkVar(t) ap(VARIDCELL,t)
@@ -195,6 +216,9 @@ extern String stringNegate Args((String));
#define isPtr(c) (isPair(c) && fst(c)==PTRCELL)
extern Cell mkPtr Args((Ptr));
extern Ptr ptrOf Args((Cell));
+#define isCPtr(c) (isPair(c) && fst(c)==CPTRCELL)
+extern Cell mkCPtr Args((Ptr));
+extern Ptr cptrOf Args((Cell));
#endif
/* --------------------------------------------------------------------------
@@ -265,6 +289,9 @@ extern Ptr ptrOf Args((Cell));
#define ONLY 81 /* ONLY snd :: Exp */
#define NEG 82 /* NEG snd :: Exp */
+/* Used when parsing GHC interface files */
+#define DICTAP 85 /* DICTTYPE snd :: (QClassId,[Type]) */
+
#if SIZEOF_INTP != SIZEOF_INT
#define PTRCELL 90 /* C Heap Pointer snd :: (Int,Int) */
#endif
@@ -392,7 +419,10 @@ struct Module {
* evaluating an expression in the context of the current module.
*/
List qualImports;
- ObjectFile objectFile; /* usually unused */
+ /* ptr to malloc'd lump of memory holding the obj file */
+ void* oImage;
+
+
};
extern Module currentModule; /* Module currently being processed */
@@ -416,16 +446,16 @@ extern Void setCurrModule Args((Module));
#define tycon(n) tabTycon[(n)-TYCMIN]
struct strTycon {
- Text text;
- Int line;
+ Text text;
+ Int line;
Module mod; /* module that defines it */
- Int arity;
- Kind kind; /* kind (includes arity) of Tycon */
- Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
- Cell defn;
- Name conToTag; /* used in derived code */
- Name tagToCon;
- Tycon nextTyconHash;
+ Int arity;
+ Kind kind; /* kind (includes arity) of Tycon */
+ Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
+ Cell defn;
+ Name conToTag; /* used in derived code */
+ Name tagToCon;
+ Tycon nextTyconHash;
};
extern struct strTycon DECTABLE(tabTycon);
@@ -467,6 +497,7 @@ struct strName {
Bool simplified; /* TRUE => already simplified */
Bool isDBuilder; /* TRUE => is a dictionary builder */
const void* primop; /* really StgPrim* */
+ List ghc_names; /* [(Text,Ptr)] */
Name nextNameHash;
};
@@ -511,6 +542,7 @@ extern Name addPrimCfun Args((Text,Int,Int,Cell));
extern Name addPrimCfunREP Args((Text,Int,Int,Int));
extern Int sfunPos Args((Name,Name));
extern Name nameFromStgVar Args((Cell));
+extern Name jrsFindQualName Args((Text,Text));
/* --------------------------------------------------------------------------
* Type class values:
@@ -523,15 +555,15 @@ extern Name nameFromStgVar Args((Cell));
#define inst(in) tabInst[(in)-INSTMIN]
struct strInst {
- Class c; /* class C */
- Int line;
- //Module mod; /* module that defines it */
- Kinds kinds; /* Kinds of variables in head */
- Cell head; /* :: Pred */
- List specifics; /* :: [Pred] */
- Int numSpecifics; /* length(specifics) */
- List implements;
- Name builder; /* Dictionary constructor function */
+ Class c; /* class C */
+ Int line;
+ Module mod; /* module that defines it */
+ Kinds kinds; /* Kinds of variables in head */
+ Cell head; /* :: Pred */
+ List specifics; /* :: [Pred] */
+ Int numSpecifics; /* length(specifics) */
+ List implements;
+ Name builder; /* Dictionary constructor function */
};
/* a predicate (an element :: Pred) is an application of a Class to one or
@@ -646,6 +678,7 @@ extern List splitAt Args((Int,List)); /* non-destructive */
extern Cell nth Args((Int,List));
extern List removeCell Args((Cell,List)); /* destructive */
extern List dupListOnto Args((List,List)); /* non-destructive */
+extern List nubList Args((List)); /* non-destructive */
/* The following macros provide `inline expansion' of some common ways of
* traversing, using and modifying lists:
@@ -714,7 +747,7 @@ extern StackPtr sp;
chkStack(1); \
onto(c); \
} while (0)
-#define onto(c) stack(++sp)=(c)
+#define onto(c) stack(++sp)=(c);
#define pop() stack(sp--)
#define drop() sp--
#define top() stack(sp)
diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index d9913e91a8518640b4961d30f14cba6fd42e50af..ff794f734939f79fb867ff04de49fb710d8f3d99 100644
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -8,8 +8,8 @@
* in the distribution for details.
*
* $RCSfile: type.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/04/27 10:07:09 $
+ * $Revision: 1.7 $
+ * $Date: 1999/06/07 17:22:31 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
@@ -724,8 +724,6 @@ Cell e; { /* requires polymorphism, qualified*/
Cell p = NIL;
Cell a = e;
Int i;
- //print(h,1000);
- //printf("\n");
switch (whatIs(h)) {
case NAME : typeIs = name(h).type;
@@ -757,9 +755,6 @@ Cell e; { /* requires polymorphism, qualified*/
}
if (isNull(typeIs)) {
- //printf("\n NAME " );
- //print(h,1000);
- //printf(" TYPE " ); print(typeIs,1000);
internal("typeAp1");
}
@@ -1709,7 +1704,7 @@ Class c; { /* defaults for class c */
body = ap(LETREC,pair(singleton(locs),body));
name(cclass(c).dbuild).defn
= singleton(pair(args,body));
- //--------- Default
+
name(cclass(c).dbuild).inlineMe = TRUE;
genDefns = cons(cclass(c).dbuild,genDefns);
cclass(c).defaults = NIL;
@@ -1854,7 +1849,7 @@ Inst in; { /* member functions for instance in*/
name(inst(in).builder).defn /* Register builder imp */
= singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
- //--------- Actual
+
name(inst(in).builder).inlineMe = TRUE;
name(inst(in).builder).isDBuilder = TRUE;
genDefns = cons(inst(in).builder,genDefns);
@@ -2250,11 +2245,6 @@ Void typeCheckDefns() { /* Type check top level bindings */
static Void local typeDefnGroup(bs) /* type check group of value defns */
List bs; { /* (one top level scc) */
List as;
- // printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n");
- //{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){
- // print(hd(qq),4);
- // printf("\n");
- //}}
emptySubstitution();
hd(defnBounds) = NIL;