From 820f09b2c2550f88aa0192442c1c62bb00d62d38 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Mon, 7 Jun 1999 17:22:54 +0000
Subject: [PATCH] [project @ 1999-06-07 17:22:31 by sewardj] Many changes
needed to support loading of GHC compiled code. The main changes are to
parser.y and interface.c to load .hi files and create appropriate symbol
table entries. Also, interface.c has the beginnings of and ELF loader/linker
in it.
---
ghc/interpreter/Makefile | 9 +-
ghc/interpreter/codegen.c | 37 +-
ghc/interpreter/compiler.c | 6 +-
ghc/interpreter/connect.h | 35 +-
ghc/interpreter/dynamic.c | 6 +-
ghc/interpreter/hugs.c | 469 +++++++---
ghc/interpreter/input.c | 85 +-
ghc/interpreter/interface.c | 1652 +++++++++++++++++++++++++++++++++++
ghc/interpreter/link.h | 2 +
ghc/interpreter/machdep.c | 156 +++-
ghc/interpreter/parser.y | 313 ++++++-
ghc/interpreter/static.c | 7 +-
ghc/interpreter/storage.c | 100 ++-
ghc/interpreter/storage.h | 81 +-
ghc/interpreter/type.c | 18 +-
15 files changed, 2762 insertions(+), 214 deletions(-)
create mode 100644 ghc/interpreter/interface.c
diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile
index 45b574be1883..0a410a9b31e2 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 ca9b482d3d3c..32d1ebf55f86 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 112ae6d31960..97e3eef3a062 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 3c444bd06d42..41dc004919a4 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 57653d578f82..3fb2a615053d 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 b9268d686937..2f426c5cdf6f 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 cc11551ff3a4..afae01fd1f7d 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 000000000000..b754bc5a39bf
--- /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 6caf0e448dbb..b87a0e7b25c1 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 ebdf4bb28fe1..2847b4141e4d 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 60e565c6e8a3..c746368b9d03 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 7b0e6011d992..09593821138c 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 7495377ad377..3d62bc568bbf 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 7cb8c411c557..861bb82b6acd 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 d9913e91a851..ff794f734939 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;
--
GitLab