From: sewardj Date: Fri, 10 Dec 1999 15:59:57 +0000 (+0000) Subject: [project @ 1999-12-10 15:59:41 by sewardj] X-Git-Tag: Approximately_9120_patches~5386 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=51c33894862dfd591d71018a70f4ca3914b17f7b;p=ghc-hetmet.git [project @ 1999-12-10 15:59:41 by sewardj] Major improvements in interface processing, and minor supporting improvements to CT-storage management. * Make the iface parser return the complete interface as a single tree, which is processed later. Added abs syntax tags I_INTERFACE .. I_VALUE to support this. * Add tagged ("z") 2,3,4,5 tuples. Because they are tagged, they can't be confused with lists, etc. Selectors zfst, zsnd ... zsel45, zsel55 check tags first. Iface processing uses z-tuples wherever it can. * Add unap as a safe "inverse" of ap; it checks tags. So unap(TAG1, ap(TAG2,cell)) == cell but only if TAG1==TAG2, else assertion failure. * In interface.c, clean up the startGHC*/endGHC* functions. processInterfaces() is the top-level driver; it makes 4 passes over the supplied iface trees. * Throw away iface symbols not mentioned in export lists. * Use iface export lists to construct both the export and eval environments for a module. * Don't use Texts to refer to things. Instead use ConId and VarId. Added ConId and VarId as synonyms for Cell in storage.h. * Add findSimpleInstance in storage.c. --- diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index c47ca21..fbd879e 100644 --- a/ghc/interpreter/codegen.c +++ b/ghc/interpreter/codegen.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: codegen.c,v $ - * $Revision: 1.13 $ - * $Date: 1999/12/06 16:25:23 $ + * $Revision: 1.14 $ + * $Date: 1999/12/10 15:59:41 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -476,10 +476,8 @@ static Void alloc( AsmBCO bco, StgVar v ) itblNames[nItblNames++] = textToStr(name(con).text); } else if (isTuple(con)) { - char cc[20]; - sprintf(cc, "Tuple%d", tupleOf(con) ); itblNames[nItblNames++] = vv; - itblNames[nItblNames++] = cc; + itblNames[nItblNames++] = textToStr(ghcTupleText(con)); } else assert ( /* cant identify constructor name */ 0 ); setPos(v,asmAllocCONSTR(bco, vv)); @@ -757,12 +755,11 @@ Void cgBinds( List binds ) Void codegen(what) Int what; { switch (what) { - case INSTALL: - /* deliberate fall though */ - case RESET: - break; - case MARK: - break; + case PREPREL: + case RESET: + case MARK: + case POSTPREL: + break; } liftControl(what); } diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 5a2fbd6..eda58cb 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.15 $ - * $Date: 1999/11/22 16:00:21 $ + * $Revision: 1.16 $ + * $Date: 1999/12/10 15:59:42 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1557,14 +1557,6 @@ Void compileDefns() { /* compile script definitions */ Target i = 0; List binds = NIL; - /* a nasty hack. But I don't know an easier way to make */ - /* these things appear. */ - if (lastModule() == modulePrelude) { - implementCfun ( nameCons, NIL ); - implementCfun ( nameNil, NIL ); - implementCfun ( nameUnit, NIL ); - } - { List vss; List vs; @@ -1653,20 +1645,17 @@ Pair p; { /* Should be merged with genDefns, */ Void compiler(what) Int what; { switch (what) { - case INSTALL : + case PREPREL : case RESET : freeVars = NIL; freeFuns = NIL; freeBegin = mkOffset(0); - //extraVars = NIL; - //numExtraVars = 0; - //localOffset = 0; - //localArity = 0; break; case MARK : mark(freeVars); mark(freeFuns); - //mark(extraVars); break; + + case POSTPREL: break; } } diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 7eb3535..f16f747 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -8,8 +8,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.20 $ - * $Date: 1999/12/03 17:56:04 $ + * $Revision: 1.21 $ + * $Date: 1999/12/10 15:59:43 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -17,6 +17,7 @@ * ------------------------------------------------------------------------*/ extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/ +extern Bool combined; /* TRUE => combined operation */ extern Module modulePrelude; /* -------------------------------------------------------------------------- @@ -177,12 +178,19 @@ extern Bool allowOverlap; /* TRUE => allow overlapping insts */ extern Void everybody Args((Int)); -#define RESET 1 /* reset subsystem */ -#define MARK 2 /* mark parts of graph in use by subsystem */ -#define INSTALL 3 /* install subsystem (executed once only) */ -#define EXIT 4 /* Take action immediately before exit() */ -#define BREAK 5 /* Take action after program break */ -#define GCDONE 6 /* Restore subsystem invariantss after GC */ + +#define RESET 1 /* reset subsystem */ +#define MARK 2 /* mark parts of graph in use by subsystem */ +#define PREPREL 3 /* do startup actions before Prelude loading */ +#define POSTPREL 4 /* do startup actions after Prelude loading */ +#define EXIT 5 /* Take action immediately before exit() */ +#define BREAK 6 /* Take action after program break */ +#define GCDONE 7 /* Restore subsystem invariantss after GC */ + +/* PREPREL was formerly called INSTALL. POSTPREL doesn't have an analogy + in the old Hugs. +*/ + typedef long Target; extern Void setGoal Args((String, Target)); @@ -545,29 +553,16 @@ extern Void interface Args((Int)); extern Void getFileSize Args((String, Long *)); -extern Void loadInterface Args((String,Long)); +extern ZPair readInterface Args((String,Long)); +extern Void processInterfaces Args((Void)); -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 List /* of ZTriple(I_INTERFACE, + Text--name of obj file, + Int--size of obj file) */ + ifaces_outstanding; -extern Void hi_o_namesFromSrcName Args((String,String*,String* oName)); -extern Void parseInterface Args((String,Long)); - - -#define SMALL_INLINE_SIZE 9 +extern Void hi_o_namesFromSrcName Args((String,String*,String* oName)); +extern Cell parseInterface Args((String,Long)); -// 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/derive.c b/ghc/interpreter/derive.c index 414c7fb..5a4010a 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: derive.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/12/01 10:22:53 $ + * $Revision: 1.11 $ + * $Date: 1999/12/10 15:59:43 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1010,8 +1010,7 @@ Tycon t; { Void deriveControl(what) Int what; { switch (what) { - case INSTALL : - /* deliberate fall through */ + case PREPREL : case RESET : diVars = NIL; diNum = 0; @@ -1022,6 +1021,8 @@ Int what; { mark(diVars); mark(cfunSfuns); break; + + case POSTPREL: break; } } diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index f5c69a1..3c11292 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.29 $ - * $Date: 1999/12/06 16:25:24 $ + * $Revision: 1.30 $ + * $Date: 1999/12/10 15:59:44 $ * ------------------------------------------------------------------------*/ #include @@ -158,6 +158,8 @@ static Int hpSize = DEFAULTHEAP; /* Desired heap size */ String hugsEdit = 0; /* String for editor command */ String hugsPath = 0; /* String for file search path */ + List ifaces_outstanding = NIL; + #if REDIRECT_OUTPUT static Bool disableOutput = FALSE; /* redirect output to buffer? */ #endif @@ -364,7 +366,8 @@ String argv[]; { Printf("Standalone mode: Restart with command line +c for combined mode\n\n" ); } - everybody(INSTALL); + everybody(PREPREL); + evalModule = findText(""); /* evaluate wrt last module by default */ if (proj) { if (namesUpto>1) { @@ -972,7 +975,6 @@ Int stacknum; { // setLastEdit(name,0); - nameObj[0] = 0; strcpy(name, scriptInfo[stacknum].path); strcat(name, scriptInfo[stacknum].modName); if (scriptInfo[stacknum].fromSource) @@ -982,7 +984,7 @@ Int stacknum; { scriptFile = name; if (scriptInfo[stacknum].fromSource) { - if (lastWasObject) finishInterfaces(); + if (lastWasObject) processInterfaces(); lastWasObject = FALSE; Printf("Reading script \"%s\":\n",name); needsImports = FALSE; @@ -992,6 +994,12 @@ Int stacknum; { typeCheckDefns(); compileDefns(); } else { + Cell iface; + List imports; + ZTriple iface_info; + char nameObj[FILENAME_MAX+1]; + Int sizeObj; + Printf("Reading iface \"%s\":\n", name); scriptFile = name; needsImports = FALSE; @@ -1002,14 +1010,25 @@ Int stacknum; { strcat(nameObj, DLL_ENDING); sizeObj = scriptInfo[stacknum].oSize; - loadInterface(name,len); + iface = readInterface(name,len); + imports = zsnd(iface); iface = zfst(iface); + + if (nonNull(imports)) chase(imports); scriptFile = 0; lastWasObject = TRUE; + + iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) ); + ifaces_outstanding = cons(iface_info,ifaces_outstanding); + if (needsImports) return FALSE; } scriptFile = 0; - preludeLoaded = TRUE; + + if (strcmp(scriptInfo[stacknum].modName, "Prelude")==0) { + preludeLoaded = TRUE; + everybody(POSTPREL); + } return TRUE; } @@ -1186,7 +1205,7 @@ Int n; { /* loading everything after and */ //numScripts = 0; while (numScripts < namesUpto) { -ppSmStack ( "readscripts-loop2" ); + ppSmStack ( "readscripts-loop2" ); if (scriptInfo[numScripts].fromSource) { @@ -1195,7 +1214,7 @@ ppSmStack ( "readscripts-loop2" ); nextNumScripts = NUM_SCRIPTS; //bogus initialisation if (addScript(numScripts)) { numScripts++; -assert(nextNumScripts==NUM_SCRIPTS); + assert(nextNumScripts==NUM_SCRIPTS); } else dropScriptsFrom(numScripts-1); @@ -1213,21 +1232,21 @@ assert(nextNumScripts==NUM_SCRIPTS); nextNumScripts = NUM_SCRIPTS; if (addScript(numScripts)) { numScripts++; -assert(nextNumScripts==NUM_SCRIPTS); + assert(nextNumScripts==NUM_SCRIPTS); } else { //while (!scriptInfo[numScripts].fromSource && numScripts > 0) // numScripts--; //if (scriptInfo[numScripts].fromSource) // numScripts++; numScripts = nextNumScripts; -assert(nextNumScripts [I_EXPORT] */ +static List getExportDeclsInIFace ( Cell root ) { - 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) + Cell iface = unap(I_INTERFACE,root); + ConId iname = zfst(iface); + List decls = zsnd(iface); + List exports = NIL; + List ds; + for (ds=decls; nonNull(ds); ds=tl(ds)) + if (whatIs(hd(ds))==I_EXPORT) + exports = cons(hd(ds), exports); + return exports; +} + + +/* Remove value bindings not mentioned in any of the export lists. */ +static Cell cleanIFace ( Cell root ) +{ + Cell c; + Cell entity; + Cell iface = unap(I_INTERFACE,root); + ConId iname = zfst(iface); + List decls = zsnd(iface); + List decls2 = NIL; + List exlist_list = NIL; + List t; + + fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname))); + + exlist_list = getExportDeclsInIFace ( root ); + /* exlist_list :: [I_EXPORT] */ + + for (t=exlist_list; nonNull(t); t=tl(t)) + hd(t) = zsnd(unap(I_EXPORT,hd(t))); + /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */ + + if (isNull(exlist_list)) { + ERRMSG(0) "Can't find any export lists in interface file" 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; + decls2 = NIL; + for (; nonNull(decls); decls=tl(decls)) { + entity = hd(decls); + if (whatIs(entity) != I_VALUE) { + decls2 = cons(entity, decls2); + } else + if (elemExportList(zsnd3(unap(I_VALUE,entity)), exlist_list)) { + decls2 = cons(entity, decls2); + fprintf ( stderr, " retain %s\n", + textToStr(textOf(zsnd3(unap(I_VALUE,entity))))); + } else { + fprintf ( stderr, " dump %s\n", + textToStr(textOf(zsnd3(unap(I_VALUE,entity))))); } - - fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n" - "\t%s\n", textToStr(tnm) ); - internal("finishGHCImports"); } - setCurrModule(tmpCurrentModule); + return ap(I_INTERFACE, zpair(iname, reverse(decls2))); } -Void loadInterface(String fname, Long fileSize) +/* ifaces_outstanding holds a list of parsed interfaces + for which we need to load objects and create symbol + table entries. +*/ +Void processInterfaces ( void ) { - ifImports = NIL; - parseInterface(fname,fileSize); - if (nonNull(ifImports)) - chase(ifImports); -} + List tmp; + List xs; + ZTriple tr; + Cell iface; + Int sizeObj; + Text nameObj; + Text mname; + List decls; + Module mod; + + fprintf ( stderr, + "processInterfaces: %d interfaces to process\n", + length(ifaces_outstanding) ); + + /* Clean up interfaces -- dump useless value bindings */ + + tmp = NIL; + for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) { + tr = hd(xs); + iface = zfst3(tr); + nameObj = zsnd3(tr); + sizeObj = zthd3(tr); + tmp = cons( ztriple(cleanIFace(iface),nameObj,sizeObj), tmp ); + } + ifaces_outstanding = reverse(tmp); + tmp = NIL; + + /* Allocate module table entries and read in object code. */ + + for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) { + tr = hd(xs); + iface = unap(I_INTERFACE,zfst3(tr)); + nameObj = zsnd3(tr); + sizeObj = zthd3(tr); + mname = textOf(zfst(iface)); + startGHCModule ( mname, intOf(sizeObj), nameObj ); + } + /* Now work through the decl lists of the modules, and call the + startGHC* functions on the entities. This creates names in + various tables but doesn't bind them to anything. + */ -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; -} + for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) { + tr = hd(xs); + iface = unap(I_INTERFACE,zfst3(tr)); + mname = textOf(zfst(iface)); + mod = findModule(mname); + if (isNull(mod)) internal("processInterfaces(4)"); + setCurrModule(mod); + + for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) { + Cell decl = hd(decls); + switch(whatIs(decl)) { + case I_EXPORT: { + Cell exdecl = unap(I_EXPORT,decl); + startGHCExports ( zfst(exdecl), zsnd(exdecl) ); + break; + } + case I_IMPORT: { + Cell imdecl = unap(I_IMPORT,decl); + startGHCImports ( zfst(imdecl), zsnd(imdecl) ); + break; + } + case I_FIXDECL: { + break; + } + case I_INSTANCE: { + Cell instance = unap(I_INSTANCE,decl); + startGHCInstance ( zsel14(instance), zsel24(instance), + zsel34(instance), zsel44(instance) ); + break; + } + case I_TYPE: { + Cell tydecl = unap(I_TYPE,decl); + startGHCSynonym ( zsel14(tydecl), zsel24(tydecl), + zsel34(tydecl), zsel44(tydecl) ); + break; + } + case I_DATA: { + Cell ddecl = unap(I_DATA,decl); + startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl), + zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) ); + break; + } + case I_NEWTYPE: { + Cell ntdecl = unap(I_NEWTYPE,decl); + startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl), + zsel35(ntdecl), zsel45(ntdecl), + zsel55(ntdecl) ); + break; + } + case I_CLASS: { + Cell klass = unap(I_CLASS,decl); + startGHCClass ( zsel15(klass), zsel25(klass), + zsel35(klass), zsel45(klass), + zsel55(klass) ); + break; + } + case I_VALUE: { + Cell value = unap(I_VALUE,decl); + startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) ); + break; + } + default: + internal("processInterfaces(1)"); + } + } + } + fprintf(stderr, "frambozenvla\n" );exit(1); -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; - } - } + /* Traverse again the decl lists of the modules, this time + calling the finishGHC* functions. But don't try process + the export lists; those must wait for later. + */ + for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) { + tr = hd(xs); + iface = unap(I_INTERFACE,zfst3(tr)); + mname = textOf(zfst(iface)); + mod = findModule(mname); + if (isNull(mod)) internal("processInterfaces(3)"); + setCurrModule(mod); + + for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) { + Cell decl = hd(decls); + switch(whatIs(decl)) { + case I_EXPORT: { + break; + } + case I_IMPORT: { + break; + } + case I_FIXDECL: { + break; + } + case I_INSTANCE: { + Cell instance = unap(I_INSTANCE,decl); + finishGHCInstance ( zsel34(instance) ); + break; + } + case I_TYPE: { + Cell tydecl = unap(I_TYPE,decl); + finishGHCSynonym ( zsel24(tydecl) ); + break; + } + case I_DATA: { + Cell ddecl = unap(I_DATA,decl); + finishGHCDataDecl ( zsel35(ddecl) ); + break; + } + case I_NEWTYPE: { + Cell ntdecl = unap(I_NEWTYPE,decl); + finishGHCNewType ( zsel35(ntdecl) ); + break; + } + case I_CLASS: { + Cell klass = unap(I_CLASS,decl); + finishGHCClass ( zsel35(klass) ); + break; + } + case I_VALUE: { + Cell value = unap(I_VALUE,decl); + finishGHCValue ( zsnd3(value) ); + break; + } + default: + internal("processInterfaces(2)"); + } + } + } + + /* Build the module(m).export lists for each module, by running + through the export lists in the iface. Also, do the implicit + 'import Prelude' thing. And finally, do the object code + linking. + */ + for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) + finishGHCModule(hd(xs)); - // Last, but by no means least ... - resolveReferencesInObjectModule ( mod, TRUE ); + /* Finished! */ + ifaces_outstanding = NIL; } -Void openGHCIface(t) -Text t; { + +/* -------------------------------------------------------------------------- + * Modules + * ------------------------------------------------------------------------*/ + +Void startGHCModule ( Text mname, Int sizeObj, Text nameObj ) +{ FILE* f; void* img; - Module m = findModule(t); + Module m = findModule(mname); if (isNull(m)) { - m = newModule(t); - //printf ( "new module %s\n", textToStr(t) ); + m = newModule(mname); + fprintf ( stderr, "startGHCIface: name %16s objsize %d\n", + textToStr(mname), sizeObj ); } else if (m != modulePrelude) { - ERRMSG(0) "Module \"%s\" already loaded", textToStr(t) + ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname) 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) + textToStr(mname) EEND; } - f = fopen( nameObj, "rb" ); + f = fopen( textToStr(nameObj), "rb" ); if (!f) { - // Really, this shouldn't happen, since makeStackEntry ensures the - // object is available. Nevertheless ... + /* 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]) + &(textToStr(nameObj)[0]) EEND; } if (sizeObj != fread ( img, 1, sizeObj, f)) { - ERRMSG(0) "Read of object file \"%s\" failed", nameObj + ERRMSG(0) "Read of object file \"%s\" failed", textToStr(nameObj) EEND; } if (!validateOImage(img,sizeObj,VERBOSE)) { - ERRMSG(0) "Validation of object file \"%s\" failed", nameObj + ERRMSG(0) "Validation of object file \"%s\" failed", + textToStr(nameObj) EEND; } @@ -414,61 +490,205 @@ Text t; { readSyms(m,VERBOSE); - if (!cellIsMember(m, ghcModules)) - ghcModules = cons(m, ghcModules); + /* setCurrModule(m); */ +} + - setCurrModule(m); +/* For the module mod, augment both the export environment (.exports) + and the eval environment (.names, .tycons, .classes) + with the symbols mentioned in exlist. We don't actually need + to touch the eval environment, since previous processing of the + top-level decls in the iface should have done this already. + + mn is the module mentioned in the export list; it is the "original" + module for the symbols in the export list. We should also record + this info with the symbols, since references to object code need to + refer to the original module in which a symbol was defined, rather + than to some module it has been imported into and then re-exported. + + Also do an implicit 'import Prelude' thingy for the module. +*/ +Void finishGHCModule ( Cell root ) +{ + /* root :: I_INTERFACE */ + Cell iface = unap(I_INTERFACE,root); + ConId iname = zfst(iface); + List decls = zsnd(iface); + Module mod = findModule(textOf(iname)); + List decls2 = NIL; + List exlist_list = NIL; + List t; + + fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname))); + + if (isNull(mod)) internal("finishExports(1)"); + setCurrModule(mod); + + exlist_list = getExportDeclsInIFace ( root ); + /* exlist_list :: [I_EXPORT] */ + + for (t=exlist_list; nonNull(t); t=tl(t)) + hd(t) = zsnd(unap(I_EXPORT,hd(t))); + /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */ + + for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) { + List exlist = hd(exlist_list); + /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */ + for (; nonNull(exlist); exlist=tl(exlist)) { + List subents; + Cell c; + Cell ex = hd(exlist); + + switch (whatIs(ex)) { + + case VARIDCELL: /* variable */ + c = findName ( textOf(ex) ); + assert(nonNull(c)); + fprintf(stderr, "var %s\n", textToStr(textOf(ex)) ); + module(mod).exports = cons(c, module(mod).exports); + break; + + case CONIDCELL: /* non data tycon */ + c = findTycon ( textOf(ex) ); + assert(nonNull(c)); + fprintf(stderr, "non data tycon %s\n", textToStr(textOf(ex)) ); + module(mod).exports = cons(c, module(mod).exports); + break; + + case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */ + subents = zsnd(ex); /* :: [ConVarId] */ + ex = zfst(ex); /* :: ConId */ + c = findTycon ( textOf(ex) ); + + if (nonNull(c)) { /* data */ + fprintf(stderr, "data %s = ", textToStr(textOf(ex)) ); + module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports); + for (; nonNull(subents); subents = tl(subents)) { + Cell ent2 = hd(subents); + assert(isCon(ent2)); + c = findName ( textOf(ent2) ); + fprintf(stderr, "%s ", textToStr(name(c).text)); + assert(nonNull(c)); + module(mod).exports = cons(c, module(mod).exports); + } + fprintf(stderr, "\n" ); + } else { /* class */ + c = findClass ( textOf(ex) ); + assert(nonNull(c)); + fprintf(stderr, "class %s where ", textToStr(textOf(ex)) ); + module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports); + for (; nonNull(subents); subents = tl(subents)) { + Cell ent2 = hd(subents); + assert(isVar(ent2)); + c = findName ( textOf(ent2) ); + fprintf(stderr, "%s ", textToStr(name(c).text)); + assert(nonNull(c)); + module(mod).exports = cons(c, module(mod).exports); + } + fprintf(stderr, "\n" ); + } + break; + + default: + internal("finishExports(2)"); + + } /* switch */ + } + } + + if (preludeLoaded) { + /* 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)); + internal("finishGHCModule -- implicit import Prelude"); + break; + } + } + } + + /* Last, but by no means least ... */ + resolveReferencesInObjectModule ( mod, VERBOSE ); } -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; +/* -------------------------------------------------------------------------- + * Exports + * ------------------------------------------------------------------------*/ + +Void startGHCExports ( ConId mn, List exlist ) +{ # ifdef DEBUG_IFACE - printf("\naddGHCImport %s\n", textToStr(mn) ); + printf("startGHCExports %s\n", textToStr(textOf(mn)) ); # endif - - /* Don't chase PrelGHC -- it doesn't exist */ - if (strncmp(textToStr(mn), "PrelGHC",7)==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 ); - } + /* Nothing to do. */ } -void addGHCVar(line,v,ty) -Int line; -Text v; -Type ty; +Void finishGHCExports ( ConId mn, List exlist ) +{ +# ifdef DEBUG_IFACE + printf("finishGHCExports %s\n", textToStr(textOf(mn)) ); +# endif + /* Nothing to do. */ +} + + +/* -------------------------------------------------------------------------- + * Imports + * ------------------------------------------------------------------------*/ + +Void startGHCImports ( ConId mn, List syms ) +/* nm the module to import from */ +/* syms [ConId | VarId] -- the names to import */ +{ +# ifdef DEBUG_IFACE + printf("startGHCImports %s\n", textToStr(textOf(mn)) ); +# endif + /* Nothing to do. */ +} + + +Void finishGHCImports ( ConId nm, List syms ) +/* nm the module to import from */ +/* syms [ConId | VarId] -- the names to import */ +{ +# ifdef DEBUG_IFACE + printf("finishGHCImports %s\n", textToStr(textOf(nm)) ); +# endif + /* Nothing to do. */ +} + + +/* -------------------------------------------------------------------------- + * Vars (values) + * ------------------------------------------------------------------------*/ + +void startGHCValue ( Int line, VarId vid, 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); + Text v = textOf(vid); + # ifdef DEBUG_IFACE - printf("\nbegin addGHCVar %s\n", s); + printf("\nbegin startGHCValue %s\n", textToStr(v)); # 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) @@ -476,47 +696,54 @@ Type ty; } n = newName(v,NIL); - tvs = nubList(ifTyvarsIn(ty)); + tvs = ifTyvarsIn(ty); for (tmp=tvs; nonNull(tmp); tmp=tl(tmp)) - hd(tmp) = pair(hd(tmp),STAR); + hd(tmp) = zpair(hd(tmp),STAR); if (nonNull(tvs)) ty = mkPolyType(tvsToKind(tvs),ty); ty = tvsToOffsets(line,ty,tvs); - /* prepare for finishGHCVar */ - name(n).type = ty; + /* prepare for finishGHCValue */ + name(n).type = ty; name(n).arity = arityInclDictParams(ty); - name(n).line = line; - ghcVarDecls = cons(n,ghcVarDecls); + name(n).line = line; # ifdef DEBUG_IFACE - printf("end addGHCVar %s\n", s); + printf("end startGHCValue %s\n", textToStr(v)); # endif } -static Void local finishGHCVar(Name n) + +void finishGHCValue ( VarId vid ) { + Name n = findName ( textOf(vid) ); Int line = name(n).line; Type ty = name(n).type; # ifdef DEBUG_IFACE - fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) ); + fprintf(stderr, "\nbegin finishGHCValue %s\n", textToStr(name(n).text) ); # endif - setCurrModule(name(n).mod); + assert(currentModule == name(n).mod); + //setCurrModule(name(n).mod); name(n).type = conidcellsToTycons(line,ty); # ifdef DEBUG_IFACE - fprintf(stderr, "end finishGHCVar %s\n", textToStr(name(n).text) ); + fprintf(stderr, "end finishGHCValue %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 () - */ + +/* -------------------------------------------------------------------------- + * Type synonyms + * ------------------------------------------------------------------------*/ + +Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty ) +{ + /* tycon :: ConId */ + /* tvs :: [((VarId,Kind))] */ + /* ty :: Type */ Text t = textOf(tycon); +# ifdef DEBUG_IFACE + fprintf(stderr, "\nbegin startGHCSynonym %s\n", textToStr(t) ); +# endif if (nonNull(findTycon(t))) { ERRMSG(line) "Repeated definition of type constructor \"%s\"", textToStr(t) @@ -530,32 +757,42 @@ Type ty; { /* prepare for finishGHCSynonym */ tycon(tc).defn = tvsToOffsets(line,ty,tvs); - ghcSynonymDecls = cons(tc,ghcSynonymDecls); } +# ifdef DEBUG_IFACE + fprintf(stderr, "end startGHCSynonym %s\n", textToStr(t) ); +# endif } -static Void local finishGHCSynonym(Tycon tc) + +static Void finishGHCSynonym ( ConId tyc ) { - Int line = tycon(tc).line; + Tycon tc = findTycon(textOf(tyc)); + Int line = tycon(tc).line; - setCurrModule(tycon(tc).mod); + assert (currentModule == tycon(tc).mod); + // setCurrModule(tycon(tc).mod); tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn); - /* ToDo: can't really do this until I've done all synonyms + /* (ADR) 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); + * (JRS) What?!?! i don't understand */ } -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,Int)],NIL)] - The NIL will become the constr's type - The Text is an optional field name - The Int indicates strictness */ + +/* -------------------------------------------------------------------------- + * Data declarations + * ------------------------------------------------------------------------*/ + +Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0) +Int line; +List ctx0; /* [((QConId,VarId))] */ +Cell tycon; /* ConId */ +List ktyvars; /* [((VarId,Kind))] */ +List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */ + /* The Text is an optional field name + The Int indicates strictness */ /* ToDo: worry about being given a decl for (->) ? * and worry about qualidents for () */ @@ -571,7 +808,7 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] Text t = textOf(tycon); # ifdef DEBUG_IFACE - fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t)); + fprintf(stderr, "\nbegin startGHCDataDecl %s\n",textToStr(t)); # endif if (nonNull(findTycon(t))) { ERRMSG(line) "Repeated definition of type constructor \"%s\"", @@ -585,7 +822,7 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] tycon(tc).kind = tvsToKind(ktyvars); tycon(tc).what = DATATYPE; - /* a list to accumulate selectors in :: [(VarId,Type)] */ + /* a list to accumulate selectors in :: [((VarId,Type))] */ sels = NIL; /* make resTy the result type of the constr, T v1 ... vn */ @@ -596,9 +833,8 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] /* for each constructor ... */ for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) { constr = hd(constrs); - conid = fst3(constr); - fields = snd3(constr); - assert(isNull(thd3(constr))); + conid = zfst(constr); + fields = zsnd(constr); /* Build type of constr and handle any selectors found. Also collect up tyvars occurring in the constr's arg @@ -606,25 +842,27 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] context later. */ ty = resTy; - tyvarsMentioned = NIL; /* [VarId] */ + tyvarsMentioned = NIL; + /* tyvarsMentioned :: [VarId] */ + conArgs = reverse(fields); for (; nonNull(conArgs); conArgs=tl(conArgs)) { conArg = hd(conArgs); /* (Type,Text) */ - conArgTy = fst3(conArg); - conArgNm = snd3(conArg); - conArgStrictness = intOf(thd3(conArg)); + conArgTy = zfst3(conArg); + conArgNm = zsnd3(conArg); + conArgStrictness = intOf(zthd3(conArg)); tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy), tyvarsMentioned); if (conArgStrictness > 0) conArgTy = bang(conArgTy); ty = fn(conArgTy,ty); if (nonNull(conArgNm)) { - /* a field name is mentioned too */ + /* 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); + sels = cons( zpair(conArgNm,selTy), sels); } } @@ -634,8 +872,9 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] */ ctx2 = NIL; for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) { - ctxElem = hd(ctx); /* (QConId,VarId) */ - if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned))) + ctxElem = hd(ctx); + /* ctxElem :: ((QConId,VarId)) */ + if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned))) ctx2 = cons(ctxElem, ctx2); } if (nonNull(ctx2)) @@ -643,50 +882,54 @@ List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)] /* 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 = pair(POLYTYPE,zpair(tycon(tc).kind, ty)); ty = tvsToOffsets(line,ty, ktyvars); /* Finally, stick the constructor's type onto it. */ - thd3(hd(constrs)) = ty; + hd(constrs) = ztriple(conid,fields,ty); } /* Final result is that - constrs :: [(ConId,[(Type,Text)],Type)] + constrs :: [((ConId,[((Type,Text))],Type))] lists the constructors and their types - sels :: [(VarId,Type)] + sels :: [((VarId,Type))] lists the selectors and their types */ - tycon(tc).defn = addGHCConstrs(line,constrs0,sels); + tycon(tc).defn = startGHCConstrs(line,constrs0,sels); } # ifdef DEBUG_IFACE - fprintf(stderr, "end addGHCDataDecl %s\n",textToStr(t)); + fprintf(stderr, "end startGHCDataDecl %s\n",textToStr(t)); # endif } -static List local addGHCConstrs(line,cons,sels) -Int line; -List cons; /* [(ConId,[(Type,Text,Int)],Type)] */ -List sels; { /* [(VarId,Type)] */ +static List startGHCConstrs ( Int line, List cons, List sels ) +{ + /* cons :: [((ConId,[((Type,Text,Int))],Type))] */ + /* sels :: [((VarId,Type))] */ + /* returns [Name] */ 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)); + Name c = startGHCConstr(line,conNo,hd(cs)); hd(cs) = c; } + /* cons :: [Name] */ + for(ss=sels; nonNull(ss); ss=tl(ss)) { - hd(ss) = addGHCSel(line,hd(ss)); + hd(ss) = startGHCSel(line,hd(ss)); } + /* sels :: [Name] */ return appendOnto(cons,sels); } -static Name local addGHCSel(line,sel) -Int line; -Pair sel; /* (VarId,Type) */ + +static Name startGHCSel ( Int line, ZPair sel ) { - Text t = textOf(fst(sel)); - Type type = snd(sel); + /* sel :: ((VarId, Type)) */ + Text t = textOf(zfst(sel)); + Type type = zsnd(sel); Name n = findName(t); if (nonNull(n)) { @@ -700,23 +943,19 @@ Pair sel; /* (VarId,Type) */ 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,Int)],Type) */ - /* ToDo: add rank2 annotation and existential annotation + +static Name startGHCConstr ( Int line, Int conNo, ZTriple constr ) +{ + /* constr :: ((ConId,[((Type,Text,Int))],Type)) */ + /* (ADR) ToDo: add rank2 annotation and existential annotation * these affect how constr can be used. */ - Text con = textOf(fst3(constr)); - Type type = thd3(constr); + Text con = textOf(zfst3(constr)); + Type type = zthd3(constr); Int arity = arityFromType(type); Name n = findName(con); /* Allocate constructor fun name */ if (isNull(n)) { @@ -729,41 +968,49 @@ Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */ name(n).arity = arity; /* Save constructor fun details */ name(n).line = line; name(n).number = cfunNo(conNo); - - /* prepare for finishGHCCon */ name(n).type = type; - ghcConstrDecls = cons(n,ghcConstrDecls); - return n; } -static Void local finishGHCConstr(Name n) + +static Void finishGHCDataDecl ( ConId tyc ) { - Int line = name(n).line; - Type ty = name(n).type; - setCurrModule(name(n).mod); + List nms; + Tycon tc = findTycon(textOf(tyc)); # ifdef DEBUG_IFACE - printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text)); + printf ( "\nbegin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) ); # endif - name(n).type = conidcellsToTycons(line,ty); + if (isNull(tc)) internal("finishGHCDataDecl"); + + for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) { + Name n = hd(nms); + Int line = name(n).line; + assert(currentModule == name(n).mod); + name(n).type = conidcellsToTycons(line,name(n).type); + } # ifdef DEBUG_IFACE - printf ( "end finishGHCConstr %s\n", textToStr(name(n).text)); + printf ( "end finishGHCDataDecl %s\n", textToStr(textOf(tyc)) ); # 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 () - */ +/* -------------------------------------------------------------------------- + * Newtype decls + * ------------------------------------------------------------------------*/ + +Void startGHCNewType ( Int line, List ctx0, + ConId tycon, List tvs, Cell constr ) +{ + /* ctx0 :: [((QConId,VarId))] */ + /* tycon :: ConId */ + /* tvs :: [((VarId,Kind))] */ + /* constr :: ((ConId,Type)) */ List tmp; Type resTy; Text t = textOf(tycon); +# ifdef DEBUG_IFACE + fprintf(stderr, "\nbegin startGHCNewType %s\n", textToStr(t) ); +# endif if (nonNull(findTycon(t))) { ERRMSG(line) "Repeated definition of type constructor \"%s\"", textToStr(t) @@ -776,64 +1023,89 @@ Cell constr; { /* (ConId,Type) */ 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); + { + /* constr :: ((ConId,Type)) */ + Text con = textOf(zfst(constr)); + Type type = zsnd(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); + + /* make resTy the result type of the constr, T v1 ... vn */ + resTy = tycon; + for (tmp=tvs; nonNull(tmp); tmp=tl(tmp)) + resTy = ap(resTy,zfst(hd(tmp))); + type = fn(type,resTy); + if (nonNull(ctx0)) + type = ap(QUAL,pair(ctx0,type)); + type = tvsToOffsets(line,type,tvs); + name(n).type = type; } } +# ifdef DEBUG_IFACE + fprintf(stderr, "end startGHCNewType %s\n", textToStr(t) ); +# endif } -Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0) -Int line; -List ctxt; /* [(QConId, VarId)] */ -Cell tc_name; /* ConId */ -Text kinded_tv; /* (VarId, Kind) */ -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, fst(kinded_tv)); + +static Void finishGHCNewType ( ConId tyc ) +{ + Tycon tc = findTycon(tyc); +# ifdef DEBUG_IFACE + printf ( "\nbegin finishGHCNewType %s\n", textToStr(textOf(tyc)) ); +# endif + + if (isNull(tc)) internal("finishGHCNewType"); + if (length(tycon(tc).defn) != 1) internal("finishGHCNewType(2)"); + { + Name n = hd(tycon(tc).defn); + Int line = name(n).line; + assert(currentModule == name(n).mod); + name(n).type = conidcellsToTycons(line,name(n).type); + } # ifdef DEBUG_IFACE - printf ( "\nbegin addGHCclass %s\n", textToStr(ct) ); + printf ( "end finishGHCNewType %s\n", textToStr(textOf(tyc)) ); # endif +} + + +/* -------------------------------------------------------------------------- + * Class declarations + * ------------------------------------------------------------------------*/ + +Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0) +Int line; +List ctxt; /* [((QConId, VarId))] */ +ConId tc_name; /* ConId */ +List kinded_tvs; /* [((VarId, Kind))] */ +List mems0; { /* [((VarId, Type))] */ + + List mems; /* [((VarId, Type))] */ + List tvsInT; /* [VarId] and then [((VarId,Kind))] */ + List tvs; /* [((VarId,Kind))] */ + + ZPair kinded_tv = hd(kinded_tvs); + Text ct = textOf(tc_name); + Pair newCtx = pair(tc_name, zfst(kinded_tv)); +# ifdef DEBUG_IFACE + printf ( "\nbegin startGHCclass %s\n", textToStr(ct) ); +# endif + + if (length(kinded_tvs) != 1) { + ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces" + EEND; + } + if (nonNull(findClass(ct))) { ERRMSG(line) "Repeated definition of class \"%s\"", textToStr(ct) @@ -863,13 +1135,13 @@ List mems0; { /* [(VarId, Type)] */ for (mems=mems0; nonNull(mems); mems=tl(mems)) { - Pair mem = hd(mems); - Type memT = snd(mem); - Text mnt = textOf(fst(mem)); - Name mn; + ZPair mem = hd(mems); + Type memT = zsnd(mem); + Text mnt = textOf(zfst(mem)); + Name mn; /* Stick the new context on the member type */ - if (whatIs(memT)==POLYTYPE) internal("addGHCClass"); + if (whatIs(memT)==POLYTYPE) internal("startGHCClass"); if (whatIs(memT)==QUAL) { memT = pair(QUAL, pair(cons(newCtx,fst(snd(memT))),snd(snd(memT)))); @@ -879,11 +1151,13 @@ List mems0; { /* [(VarId, Type)] */ } /* Cook up a kind for the type. */ - tvsInT = nubList(ifTyvarsIn(memT)); + tvsInT = ifTyvarsIn(memT); + /* tvsInT :: [VarId] */ /* ToDo: maximally bogus */ for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) - hd(tvs) = pair(hd(tvs),STAR); + hd(tvs) = zpair(hd(tvs),STAR); + /* tvsIntT :: [((VarId,STAR))] */ memT = mkPolyType(tvsToKind(tvsInT),memT); memT = tvsToOffsets(line,memT,tvsInT); @@ -904,9 +1178,8 @@ List mems0; { /* [(VarId, Type)] */ cclass(nw).members = mems0; cclass(nw).numMembers = length(mems0); - ghcClassDecls = cons(nw,ghcClassDecls); - /* ToDo: + /* (ADR) ToDo: * cclass(nw).dsels = ?; * cclass(nw).dbuild = ?; * cclass(nm).dcon = ?; @@ -914,26 +1187,30 @@ List mems0; { /* [(VarId, Type)] */ */ } # ifdef DEBUG_IFACE - printf ( "end addGHCclass %s\n", textToStr(ct) ); + printf ( "end startGHCclass %s\n", textToStr(ct) ); # endif } -static Void local finishGHCClass(Class nw) -{ - List mems; - Int line = cclass(nw).line; - Int ctr = - length(cclass(nw).members); +static Void finishGHCClass ( Tycon cls_tyc ) +{ + List mems; + Int line; + Int ctr; + Class nw = findClass ( textOf(cls_tyc) ); # ifdef DEBUG_IFACE printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) ); # endif + if (isNull(nw)) internal("finishGHCClass"); - setCurrModule(cclass(nw).mod); + line = cclass(nw).line; + ctr = - length(cclass(nw).members); + assert (currentModule == 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); + cclass(nw).level = 0; /* (ADR) 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) */ @@ -951,26 +1228,32 @@ static Void local finishGHCClass(Class nw) # endif } -Void addGHCInstance (line,ctxt0,cls,var) -Int line; -List ctxt0; /* [(QConId, Type)] */ -List cls; /* [(ConId, Type)] */ -Text var; { /* Text */ + +/* -------------------------------------------------------------------------- + * Instances + * ------------------------------------------------------------------------*/ + +Void startGHCInstance (line,ctxt0,cls,var) +Int line; +List ctxt0; /* [(QConId, VarId)] */ +Type cls; /* Type */ +VarId var; { /* VarId */ List tmp, tvs, ks; Inst in = newInst(); # ifdef DEBUG_IFACE - printf ( "\nbegin addGHCInstance\n" ); + printf ( "\nbegin startGHCInstance\n" ); # endif /* Make tvs into a list of tyvars with bogus kinds. */ - //print ( cls, 10 ); printf ( "\n"); - tvs = nubList(ifTyvarsIn(cls)); - //print ( tvs, 10 ); + tvs = ifTyvarsIn(cls); + /* tvs :: [VarId] */ + ks = NIL; for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) { - hd(tmp) = pair(hd(tmp),STAR); + hd(tmp) = zpair(hd(tmp),STAR); ks = cons(STAR,ks); } + /* tvs :: [((VarId,STAR))] */ inst(in).line = line; inst(in).implements = NIL; @@ -979,7 +1262,7 @@ Text var; { /* Text */ inst(in).numSpecifics = length(ctxt0); inst(in).head = tvsToOffsets(line,cls,tvs); #if 0 -Is this still needed? + Is this still needed? { Name b = newName(inventText(),NIL); name(b).line = line; @@ -989,22 +1272,39 @@ Is this still needed? bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); } #endif - ghcInstanceDecls = cons(in, ghcInstanceDecls); # ifdef DEBUG_IFACE - printf ( "end addGHCInstance\n" ); + printf ( "end startGHCInstance\n" ); # endif } -static Void local finishGHCInstance(Inst in) + +static Void finishGHCInstance ( Type cls ) { - Int line = inst(in).line; - Cell cl = fst(inst(in).head); + /* Cls is the { C1 a1 } -> ... -> { Cn an }, where + an isn't a type variable -- it's a data or tuple. */ + Inst in; + Int line; + Cell cl; Class c; + ConId conid_cls; + ConId conid_ty; + # ifdef DEBUG_IFACE printf ( "\nbegin finishGHCInstance\n" ); # endif - setCurrModule(inst(in).mod); + cls = snd(cls); /* { Cn an } */ + conid_cls = fst(cls); + conid_ty = snd(cls); + + if (whatIs(conid_cls) != CONIDCELL || + whatIs(conid_ty ) != CONIDCELL) internal("finishGHCInstance"); + + in = findSimpleInstance ( conid_cls, conid_ty ); + line = inst(in).line; + cl = fst(inst(in).head); + + assert (currentModule==inst(in).mod); c = findClass(textOf(cl)); if (isNull(c)) { ERRMSG(line) "Unknown class \"%s\" in instance", @@ -1019,20 +1319,25 @@ static Void local finishGHCInstance(Inst in) # endif } + /* -------------------------------------------------------------------------- * Helper fns * ------------------------------------------------------------------------*/ -/* This is called from the addGHC* functions. It traverses a structure +/* This is called from the startGHC* 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. + + ((t1,t2)) denotes the typed (z-)pair type of t1 and t2. */ -static Type local tvsToOffsets(line,type,ktyvars) + +/* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */ +static Type tvsToOffsets(line,type,ktyvars) Int line; Type type; -List ktyvars; { /* [(VarId|Text,Kind)] */ +List ktyvars; { /* [(VarId,Kind)] */ switch (whatIs(type)) { case NIL: case TUPLE: @@ -1040,6 +1345,9 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ case CONIDCELL: case TYCON: return type; + case ZTUP2: /* convert to the untyped representation */ + return ap( tvsToOffsets(line,zfst(type),ktyvars), + tvsToOffsets(line,zsnd(type),ktyvars) ); case AP: return ap( tvsToOffsets(line,fun(type),ktyvars), tvsToOffsets(line,arg(type),ktyvars) ); @@ -1062,8 +1370,11 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ { 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; + Cell varid; + Text tt; +assert(isZPair(hd(ktyvars))); + varid = zfst(hd(ktyvars)); + tt = textOf(varid); if (tv == tt) return mkOffset(i); } ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv) @@ -1095,12 +1406,11 @@ static Text kludgeGHCPrelText ( Text m ) 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 + of interface loading (finishGHC* rather than startGHC*) 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) +static Type conidcellsToTycons(line,type) Int line; Type type; { switch (whatIs(type)) { @@ -1181,18 +1491,21 @@ Type type; { * so they can be performed while reading interfaces. * ------------------------------------------------------------------------*/ -static Kinds local tvsToKind(tvs) -List tvs; { /* [(VarId,Kind)] */ +/* tvsToKind :: [((VarId,Kind))] -> Kinds */ +static Kinds 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); + if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)"); + if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)"); + r = ap(zsnd(hd(rs)),r); } return r; } -static Int local arityInclDictParams ( Type type ) +static Int arityInclDictParams ( Type type ) { Int arity = 0; if (isPolyType(type)) type = monotypeOf(type); @@ -1210,7 +1523,7 @@ static Int local arityInclDictParams ( Type type ) } /* arity of a constructor with this type */ -static Int local arityFromType(type) +static Int arityFromType(type) Type type; { Int arity = 0; if (isPolyType(type)) { @@ -1233,18 +1546,16 @@ Type type; { } -static List local ifTyvarsIn(type) +/* ifTyvarsIn :: Type -> [VarId] + The returned list has no duplicates -- is a set. +*/ +static List ifTyvarsIn(type) Type type; { List vs = typeVarsIn(type,NIL,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 { + for (; nonNull(vs2); vs2=tl(vs2)) + if (whatIs(hd(vs2)) != VARIDCELL) internal("ifTyvarsIn"); - } - } return vs; } @@ -1257,7 +1568,7 @@ Type type; { #include -static char* local findElfSection ( void* objImage, Elf32_Word sh_type ) +static char* findElfSection ( void* objImage, Elf32_Word sh_type ) { Int i; char* ehdrC = (char*)objImage; @@ -1275,7 +1586,7 @@ static char* local findElfSection ( void* objImage, Elf32_Word sh_type ) } -static Void local resolveReferencesInObjectModule_elf ( Module m, +static Void resolveReferencesInObjectModule_elf ( Module m, Bool verb ) { char symbol[1000]; // ToDo @@ -1365,7 +1676,7 @@ static Void local resolveReferencesInObjectModule_elf ( Module m, } -static Bool local validateOImage_elf ( void* imgV, +static Bool validateOImage_elf ( void* imgV, Int size, Bool verb ) { @@ -1596,7 +1907,7 @@ static void readSyms_elf ( Module m, Bool verb ) * Arch-independent interface to the runtime linker * ------------------------------------------------------------------------*/ -static Bool local validateOImage ( void* img, Int size, Bool verb ) +static Bool validateOImage ( void* img, Int size, Bool verb ) { #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) return @@ -1607,7 +1918,7 @@ static Bool local validateOImage ( void* img, Int size, Bool verb ) } -static Void local resolveReferencesInObjectModule ( Module m, Bool verb ) +static Void resolveReferencesInObjectModule ( Module m, Bool verb ) { #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) resolveReferencesInObjectModule_elf ( m, verb ); @@ -1617,7 +1928,7 @@ static Void local resolveReferencesInObjectModule ( Module m, Bool verb ) } -static Void local readSyms ( Module m, Bool verb ) +static Void readSyms ( Module m, Bool verb ) { #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) readSyms_elf ( m, verb ); @@ -1723,29 +2034,15 @@ int is_not_dynamically_loaded_ptr ( char* p ) 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; - break; - case MARK: - mark(ifImports); - mark(ghcVarDecls); - mark(ghcConstrDecls); - mark(ghcSynonymDecls); - mark(ghcClassDecls); - mark(ghcInstanceDecls); - mark(ghcImports); - mark(ghcExports); - mark(ghcModules); - break; + case POSTPREL: break; + + case PREPREL: + case RESET: + ifaces_outstanding = NIL; + break; + case MARK: + mark(ifaces_outstanding); + break; } } diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index e5ddb05..be292ba 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: lift.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/11/29 18:59:29 $ + * $Revision: 1.10 $ + * $Date: 1999/12/10 15:59:47 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -200,14 +200,15 @@ List liftBinds( List binds ) Void liftControl(what) Int what; { switch (what) { - case INSTALL: - /* deliberate fall though */ - case RESET: - liftedBinds = NIL; - break; - case MARK: - mark(liftedBinds); - break; + case POSTPREL: break; + + case PREPREL: + case RESET: + liftedBinds = NIL; + break; + case MARK: + mark(liftedBinds); + break; } } diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index d7d9bdb..dbab049 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.20 $ - * $Date: 1999/12/06 16:25:25 $ + * $Revision: 1.21 $ + * $Date: 1999/12/10 15:59:48 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -199,6 +199,7 @@ Kind starToStar; /* Type -> Type */ Cell predMonad; /* Monad (mkOffset(0)) */ Type typeProgIO; /* IO a */ + /* -------------------------------------------------------------------------- * * ------------------------------------------------------------------------*/ @@ -206,7 +207,6 @@ Type typeProgIO; /* IO a */ static Tycon linkTycon ( String s ); static Tycon linkClass ( String s ); static Name linkName ( String s ); -static Void mkTypes ( void ); static Name predefinePrim ( String s ); @@ -254,6 +254,21 @@ static Name predefinePrim ( String s ) return nm; } + +/* -------------------------------------------------------------------------- + * + * ------------------------------------------------------------------------*/ + +/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPreludeNames + are called, in that order, during static analysis of Prelude.hs. + In combined mode such an analysis does not happen. Instead these + calls will be made as a result of a call link(POSTPREL). + + linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both + standalone and combined modes. +*/ + + Void linkPreludeTC(void) { /* Hook to tycons and classes in */ static Bool initialised = FALSE; /* prelude when first loaded */ if (!initialised) { @@ -261,100 +276,95 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ initialised = TRUE; setCurrModule(modulePrelude); - typeChar = linkTycon("Char"); - typeInt = linkTycon("Int"); - typeInteger = linkTycon("Integer"); - typeWord = linkTycon("Word"); - typeAddr = linkTycon("Addr"); + typeChar = linkTycon("Char"); + typeInt = linkTycon("Int"); + typeInteger = linkTycon("Integer"); + typeWord = linkTycon("Word"); + typeAddr = linkTycon("Addr"); typePrimArray = linkTycon("PrimArray"); typePrimByteArray = linkTycon("PrimByteArray"); typeRef = linkTycon("STRef"); typePrimMutableArray = linkTycon("PrimMutableArray"); typePrimMutableByteArray = linkTycon("PrimMutableByteArray"); - typeFloat = linkTycon("Float"); - typeDouble = linkTycon("Double"); - typeStable = linkTycon("StablePtr"); -#ifdef PROVIDE_WEAK - typeWeak = linkTycon("Weak"); -#endif -#ifdef PROVIDE_FOREIGN - typeForeign = linkTycon("ForeignObj"); -#endif - typeThreadId = linkTycon("ThreadId"); - typeMVar = linkTycon("MVar"); - typeBool = linkTycon("Bool"); - typeST = linkTycon("ST"); - typeIO = linkTycon("IO"); - typeException = linkTycon("Exception"); - typeString = linkTycon("String"); - typeOrdering = linkTycon("Ordering"); - - classEq = linkClass("Eq"); - classOrd = linkClass("Ord"); - classIx = linkClass("Ix"); - classEnum = linkClass("Enum"); - classShow = linkClass("Show"); - classRead = linkClass("Read"); - classBounded = linkClass("Bounded"); - classReal = linkClass("Real"); - classIntegral = linkClass("Integral"); - classRealFrac = linkClass("RealFrac"); - classRealFloat = linkClass("RealFloat"); - classFractional = linkClass("Fractional"); - classFloating = linkClass("Floating"); - classNum = linkClass("Num"); - classMonad = linkClass("Monad"); - - stdDefaults = NIL; - stdDefaults = cons(typeDouble,stdDefaults); -#if DEFAULT_BIGNUM - stdDefaults = cons(typeInteger,stdDefaults); -#else - stdDefaults = cons(typeInt,stdDefaults); -#endif - mkTypes(); - - nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); - nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); - nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); - nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); - nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); - nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); - nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); - nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); - -#ifdef PROVIDE_FOREIGN - nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); -#endif -#ifdef PROVIDE_WEAK - nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); -#endif - nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); - nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); - nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0); - nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); + typeFloat = linkTycon("Float"); + typeDouble = linkTycon("Double"); + typeStable = linkTycon("StablePtr"); +# ifdef PROVIDE_WEAK + typeWeak = linkTycon("Weak"); +# endif +# ifdef PROVIDE_FOREIGN + typeForeign = linkTycon("ForeignObj"); +# endif + typeThreadId = linkTycon("ThreadId"); + typeMVar = linkTycon("MVar"); + typeBool = linkTycon("Bool"); + typeST = linkTycon("ST"); + typeIO = linkTycon("IO"); + typeException = linkTycon("Exception"); + typeString = linkTycon("String"); + typeOrdering = linkTycon("Ordering"); + + classEq = linkClass("Eq"); + classOrd = linkClass("Ord"); + classIx = linkClass("Ix"); + classEnum = linkClass("Enum"); + classShow = linkClass("Show"); + classRead = linkClass("Read"); + classBounded = linkClass("Bounded"); + classReal = linkClass("Real"); + classIntegral = linkClass("Integral"); + classRealFrac = linkClass("RealFrac"); + classRealFloat = linkClass("RealFloat"); + classFractional = linkClass("Fractional"); + classFloating = linkClass("Floating"); + classNum = linkClass("Num"); + classMonad = linkClass("Monad"); + + stdDefaults = NIL; + stdDefaults = cons(typeDouble,stdDefaults); +# if DEFAULT_BIGNUM + stdDefaults = cons(typeInteger,stdDefaults); +# else + stdDefaults = cons(typeInt,stdDefaults); +# endif + + predNum = ap(classNum,aVar); + predFractional = ap(classFractional,aVar); + predIntegral = ap(classIntegral,aVar); + predMonad = ap(classMonad,aVar); + typeProgIO = ap(typeIO,aVar); + + nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP); + nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP); + nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP); + nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP); + nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); + nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); + nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); + nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); + +# ifdef PROVIDE_FOREIGN + nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); +# endif +# ifdef PROVIDE_WEAK + nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0); +# endif + nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0); + nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0); + nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0); + nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); - nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0); - nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); - - /* The following primitives are referred to in derived instances and - * hence require types; the following types are a little more general - * than we might like, but they are the closest we can get without a - * special datatype class. - */ - - name(namePrimSeq).type - = primType(MONAD_Id, "ab", "b"); - name(namePrimCatch).type - = primType(MONAD_Id, "aH", "a"); - name(namePrimRaise).type - = primType(MONAD_Id, "E", "a"); + nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0); + nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); + + name(namePrimSeq).type = primType(MONAD_Id, "ab", "b"); + name(namePrimCatch).type = primType(MONAD_Id, "aH", "a"); + name(namePrimRaise).type = primType(MONAD_Id, "E", "a"); /* This is a lie. For a more accurate type of primTakeMVar see ghc/interpreter/lib/Prelude.hs. */ - name(namePrimTakeMVar).type - = primType(MONAD_Id, "rbc", "d"); + name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d"); for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */ addTupInst(classEq,i); @@ -367,15 +377,6 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ } } -static Void mkTypes ( void ) -{ - predNum = ap(classNum,aVar); - predFractional = ap(classFractional,aVar); - predIntegral = ap(classIntegral,aVar); - predMonad = ap(classMonad,aVar); - typeProgIO = ap(typeIO,aVar); -} - Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ static Bool initialised = FALSE; /* prelude when first loaded */ if (!initialised) { @@ -452,9 +453,9 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ nameOtherwise = linkName("otherwise"); nameUndefined = linkName("undefined"); /* pmc */ -#if NPLUSK +# if NPLUSK namePmSub = linkName("primPmSub"); -#endif +# endif /* translator */ nameEqChar = linkName("primEqChar"); nameCreateAdjThunk = linkName("primCreateAdjThunk"); @@ -465,10 +466,18 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ namePmFromInteger = linkName("primPmFromInteger"); namePmSubtract = linkName("primPmSubtract"); namePmLe = linkName("primPmLe"); + + implementCfun ( nameCons, NIL ); + implementCfun ( nameNil, NIL ); + implementCfun ( nameUnit, NIL ); } } +/* -------------------------------------------------------------------------- + * + * ------------------------------------------------------------------------*/ + /* ToDo: fix pFun (or eliminate its use) */ #define pFun(n,s) n = predefinePrim(s) @@ -480,103 +489,112 @@ Int what; { case MARK : break; - case INSTALL : linkControl(RESET); - - modulePrelude = newModule(textPrelude); - setCurrModule(modulePrelude); - - for(i=0; i)"), - pair(STAR,pair(STAR,STAR)), - 2,DATATYPE,NIL); - - /* newtype and USE_NEWTYPE_FOR_DICTS */ - pFun(nameId, "id"); - - /* desugaring */ - pFun(nameInd, "_indirect"); - name(nameInd).number = DFUNNAME; - - /* pmc */ - pFun(nameSel, "_SEL"); - - /* strict constructors */ - pFun(nameFlip, "flip" ); - - /* parser */ - pFun(nameFromTo, "enumFromTo"); - pFun(nameFromThenTo, "enumFromThenTo"); - pFun(nameFrom, "enumFrom"); - pFun(nameFromThen, "enumFromThen"); - - /* deriving */ - pFun(nameApp, "++"); - pFun(nameReadField, "readField"); - pFun(nameReadParen, "readParen"); - pFun(nameShowField, "showField"); - pFun(nameShowParen, "showParen"); - pFun(nameLex, "lex"); - pFun(nameComp, "."); - pFun(nameAnd, "&&"); - pFun(nameCompAux, "primCompAux"); - pFun(nameMap, "map"); - - /* implementTagToCon */ - pFun(namePMFail, "primPmFail"); - pFun(nameError, "error"); - pFun(nameUnpackString, "primUnpackString"); - - /* hooks for handwritten bytecode */ - pFun(namePrimSeq, "primSeq"); - pFun(namePrimCatch, "primCatch"); - pFun(namePrimRaise, "primRaise"); - pFun(namePrimTakeMVar, "primTakeMVar"); - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimSeq; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - vv = mkStgVar(NIL,NIL); - stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - namePrimSeq = n; - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimCatch; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimRaise; - name(n).line = 0; - name(n).arity = 1; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - { - StgVar vv = mkStgVar(NIL,NIL); - Name n = namePrimTakeMVar; - name(n).line = 0; - name(n).arity = 2; - name(n).type = NIL; - stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); - name(n).stgVar = vv; - stgGlobals=cons(pair(n,vv),stgGlobals); - } - break; + case POSTPREL: + fprintf(stderr, "linkControl(POSTPREL)\n"); +if (combined) assert(0); +break; + + case PREPREL : + + modulePrelude = newModule(textPrelude); + setCurrModule(modulePrelude); + + for (i=0; i)"), + pair(STAR,pair(STAR,STAR)), + 2,DATATYPE,NIL); + + /* newtype and USE_NEWTYPE_FOR_DICTS */ + pFun(nameId, "id"); + + /* desugaring */ + pFun(nameInd, "_indirect"); + name(nameInd).number = DFUNNAME; + + /* pmc */ + pFun(nameSel, "_SEL"); + + /* strict constructors */ + pFun(nameFlip, "flip" ); + + /* parser */ + pFun(nameFromTo, "enumFromTo"); + pFun(nameFromThenTo, "enumFromThenTo"); + pFun(nameFrom, "enumFrom"); + pFun(nameFromThen, "enumFromThen"); + + /* deriving */ + pFun(nameApp, "++"); + pFun(nameReadField, "readField"); + pFun(nameReadParen, "readParen"); + pFun(nameShowField, "showField"); + pFun(nameShowParen, "showParen"); + pFun(nameLex, "lex"); + pFun(nameComp, "."); + pFun(nameAnd, "&&"); + pFun(nameCompAux, "primCompAux"); + pFun(nameMap, "map"); + + /* implementTagToCon */ + pFun(namePMFail, "primPmFail"); + pFun(nameError, "error"); + pFun(nameUnpackString, "primUnpackString"); + + /* hooks for handwritten bytecode */ + pFun(namePrimSeq, "primSeq"); + pFun(namePrimCatch, "primCatch"); + pFun(namePrimRaise, "primRaise"); + pFun(namePrimTakeMVar, "primTakeMVar"); + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimSeq; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + vv = mkStgVar(NIL,NIL); + stgVarInfo(vv) = mkPtr ( asm_BCO_seq() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + namePrimSeq = n; + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimCatch; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_catch() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimRaise; + name(n).line = 0; + name(n).arity = 1; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_raise() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + { + StgVar vv = mkStgVar(NIL,NIL); + Name n = namePrimTakeMVar; + name(n).line = 0; + name(n).arity = 2; + name(n).type = NIL; + stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() ); + name(n).stgVar = vv; + stgGlobals=cons(pair(n,vv),stgGlobals); + } + } + break; } } #undef pFun diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index cbe9d54..369fc45 100644 --- a/ghc/interpreter/machdep.c +++ b/ghc/interpreter/machdep.c @@ -13,8 +13,8 @@ * included in the distribution. * * $RCSfile: machdep.c,v $ - * $Revision: 1.16 $ - * $Date: 1999/12/03 14:38:39 $ + * $Revision: 1.17 $ + * $Date: 1999/12/10 15:59:48 $ * ------------------------------------------------------------------------*/ #ifdef HAVE_SIGNAL_H @@ -1543,7 +1543,8 @@ Void machdep(what) /* Handle machine specific */ Int what; { /* initialisation etc.. */ switch (what) { case MARK : break; - case INSTALL : installHandlers(); + case POSTPREL: break; + case PREPREL : installHandlers(); break; case RESET : case BREAK : diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 300028d..47b1ff4 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.17 $ - * $Date: 1999/12/03 17:01:22 $ + * $Revision: 1.18 $ + * $Date: 1999/12/10 15:59:49 $ * ------------------------------------------------------------------------*/ %{ @@ -120,80 +120,74 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} */ /*- Top-level interface files -----------------------------*/ -iface : INTERFACE ifName NUMLIT orphans checkVersion WHERE ifDecls - {$$ = gc7(NIL); } +iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls + {$$ = gc7(ap(I_INTERFACE, + zpair($2,$7))); } | INTERFACE error {syntaxError("interface file");} ; -ifDecls: {$$=gc0(NIL);} - | ifDecl ';' ifDecls {$$=gc3(cons($1,$3));} - ; -varid_or_conid - : VARID { $$=gc1($1); } - | CONID { $$=gc1($1); } - ; -ifName : CONID {openGHCIface(textOf($1)); - $$ = gc1(NIL);} -checkVersion - : NUMLIT {$$ = gc1(NIL); } +ifTopDecls: {$$=gc0(NIL);} + | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));} ; -ifDecl - : IMPORT CONID NUMLIT orphans opt_COCO version_list_junk - { addGHCImports(intOf($3),textOf($2), - $6); - $$ = gc6(NIL); - } - | INSTIMPORT CONID {$$=gc2(NIL);} +ifTopDecl + : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList + {$$=gc6(ap(I_IMPORT,zpair($2,$6))); } + + | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));} - | UUEXPORT CONID ifEntities { addGHCExports($2,$3); - $$=gc3(NIL);} + | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));} - | 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)); } + | NUMLIT INFIXL optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(LEFT_ASS),$4)));} + | NUMLIT INFIXR optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(RIGHT_ASS),$4)));} + | NUMLIT INFIXN optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(NON_ASS),$4)));} | TINSTANCE ifCtxInst ifInstHdL '=' ifVar - { addGHCInstance(intOf($1),$2,$3, - textOf($5)); - $$ = gc5(NIL); } + {$$=gc5(ap(I_INSTANCE, + z4ble($1,$2,$3,$5)));} + | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType - { addGHCSynonym(intOf($2),$3,$4,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_TYPE, + z4ble($2,$3,$4,$6)));} | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs - { addGHCDataDecl(intOf($2), - $3,$4,$5,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_DATA, + z5ble($2,$3,$4,$5,$6)));} | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr - { addGHCNewType(intOf($2), - $3,$4,$5,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_NEWTYPE, + z5ble($2,$3,$4,$5,$6)));} + | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths - { addGHCClass(intOf($2),$3,$4,$5,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_CLASS, + z5ble($2,$3,$4, + singleton($5),$6)));} + | NUMLIT ifVar COCO ifType - { addGHCVar(intOf($3),textOf($2),$4); - $$ = gc4(NIL); } + {$$=gc4(ap(I_VALUE, + ztriple($3,$2,$4)));} + | error { syntaxError( "interface declaration"); } ; /*- Top-level misc interface stuff ------------------------*/ -orphans : '!' {$$=gc1(NIL);} +ifOrphans : '!' {$$=gc1(NIL);} | {$$=gc0(NIL);} ; -opt_COCO : COCO {$$=gc1(NIL);} +ifOptCOCO : COCO {$$=gc1(NIL);} | {$$=gc0(NIL);} ; +ifCheckVersion + : NUMLIT {$$ = gc1(NIL); } + ; @@ -204,6 +198,11 @@ ifVar : VARID {$$ = gc1($1);} ; ifCon : CONID {$$ = gc1($1);} ; + +ifVarCon : VARID {$$ = gc1($1);} + | CONID {$$ = gc1($1);} + ; + ifQCon : CONID {$$ = gc1($1);} | QCONID {$$ = gc1($1);} ; @@ -231,74 +230,74 @@ ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} => */ | {$$=gc0(NIL);} ; ifInstHd /* { Class aType } :: (ConId, Type) */ - : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,pair($2,singleton($3))));} + : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP, + zpair($2,singleton($3))));} ; -ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: [(ConId, Type)] */ - /* Note: not constructing the list with fn($1,$3) */ +ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */ : ifInstHd ARROW ifInstHdL {$$=gc3(fn($1,$3));} | ifInstHd {$$=gc1(NIL);} ; - ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */ - : { $$ = gc0(NIL); } - | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); } + : ifCtxDeclT IMPLIES { $$ = gc2($1); } + | { $$ = gc0(NIL); } ; 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));} + : ifQCon ifTyvar {$$=gc2(zpair($1,$2));} ; /*- Interface data declarations - constructor lists -------*/ -/* The (Type,Text,Int) are (field type, name (or NIL), strictness). +/* The (Type,VarId,Int) are (field type, name (or NIL), strictness). Strictness is a number: mkInt(0) indicates lazy, mkInt(1) indicates a strict field (!type) as in standard H98, and mkInt(2) indicates unpacked -- a GHC extension. */ -ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text,Int)],NIL)] */ +ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,VarId,Int)])] */ : {$$ = gc0(NIL);} | '=' ifConstrL {$$ = gc2($2);} ; -ifConstrL /* [(ConId,[(Type,Text,Int)],NIL)] */ +ifConstrL /* [(ConId,[(Type,VarId,Int)])] */ : ifConstr {$$ = gc1(singleton($1));} | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));} ; -ifConstr /* (ConId,[(Type,Text,Int)],NIL) */ - : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));} +ifConstr /* (ConId,[(Type,VarId,Int)]) */ + : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));} | ifConData '{' ifDataNamedFieldL '}' - {$$ = gc4(triple($1,$3,NIL));} + {$$ = gc4(zpair($1,$3));} ; -ifDataAnonFieldL /* [(Type,Text,Int)] */ +ifDataAnonFieldL /* [(Type,VarId,Int)] */ : {$$=gc0(NIL);} | ifDataAnonField ifDataAnonFieldL {$$=gc2(cons($1,$2));} ; -ifDataNamedFieldL /* [(Type,Text,Int)] */ +ifDataNamedFieldL /* [(Type,VarId,Int)] */ : {$$=gc0(NIL);} | ifDataNamedField {$$=gc1(cons($1,NIL));} | ifDataNamedField ',' ifDataNamedFieldL {$$=gc3(cons($1,$3));} ; -ifDataAnonField /* (Type,Text,Int) */ - : ifAType {$$=gc1(triple($1,NIL,mkInt(0)));} - | '!' ifAType {$$=gc2(triple($2,NIL,mkInt(1)));} - | '!' '!' ifAType {$$=gc3(triple($3,NIL,mkInt(2)));} +ifDataAnonField /* (Type,VarId,Int) */ + : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));} + | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));} + | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));} ; -ifDataNamedField /* (Type,Text,Int) */ - : VARID COCO ifAType {$$=gc3(triple($3,$1,mkInt(0)));} - | VARID COCO '!' ifAType {$$=gc4(triple($4,$1,mkInt(1)));} - | VARID COCO '!' '!' ifAType {$$=gc5(triple($5,$1,mkInt(2)));} +ifDataNamedField /* (Type,VarId,Int) */ + : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));} + | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));} + | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));} ; @@ -312,15 +311,15 @@ ifCmethL /* [(VarId,Type)] */ | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); } ; ifCmeth /* (VarId,Type) */ - : ifVar COCO ifType { $$ = gc3(pair($1,$3)); } - | ifVar '=' COCO ifType { $$ = gc4(pair($1,$4)); } + : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); } + | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); } /* has default method */ ; /*- Interface newtype declararions ------------------------*/ ifNewTypeConstr /* (ConId,Type) */ - : '=' ifCon ifAType { $$ = gc3(pair($2,$3)); } + : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); } ; @@ -381,8 +380,8 @@ ifKindedTyvarL /* [(VarId,Kind)] */ | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); } ; ifKindedTyvar /* (VarId,Kind) */ - : ifTyvar { $$ = gc1(pair($1,STAR)); } - | ifTyvar COCO ifAKind { $$ = gc3(pair($1,$3)); } + : ifTyvar { $$ = gc1(zpair($1,STAR)); } + | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); } ; ifKind : ifAKind { $$ = gc1($1); } | ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); } @@ -400,7 +399,7 @@ ifEntities ; ifEntity : ifEntityOcc {$$=gc1($1);} - | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));} + | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));} ; ifEntityOcc : ifVar { $$ = gc1($1); } @@ -417,15 +416,15 @@ ifValOccs | ifVar ifValOccs { $$ = gc2(cons($1,$2)); } | ifCon ifValOccs { $$ = gc2(cons($1,$2)); } ; -version_list_junk - : {$$=gc0(NIL);} - | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));} - | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));} + +ifVersionList + : {$$=gc0(NIL);} + | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));} + | CONID NUMLIT ifVersionList {$$=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. diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 33dc2ee..1a20f20 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.19 $ - * $Date: 1999/12/03 12:39:44 $ + * $Revision: 1.20 $ + * $Date: 1999/12/10 15:59:50 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -5035,7 +5035,8 @@ Void checkDefns() { /* Top level static analysis */ } mapProc(checkImportList, unqualImports); - linkPreludeTC(); /* Get prelude tycons and classes */ + if (!combined) linkPreludeTC(); /* Get prelude tycons and classes */ + mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */ checkSynonyms(tyconDefns); /* check synonym definitions */ mapProc(checkClassDefn,classDefns); /* process class definitions */ @@ -5043,7 +5044,8 @@ Void checkDefns() { /* Top level static analysis */ mapProc(extendFundeps,classDefns); /* finish class definitions */ mapProc(addMembers,classDefns); /* add definitions for member funs */ mapProc(visitClass,classDefns); /* check class hierarchy */ - linkPreludeCM(); /* Get prelude cfuns and mfuns */ + + if (!combined) linkPreludeCM(); /* Get prelude cfuns and mfuns */ instDefns = rev(instDefns); /* process instance definitions */ mapProc(checkInstDefn,instDefns); @@ -5059,7 +5061,7 @@ Void checkDefns() { /* Top level static analysis */ mapProc(allNoPrevDef,valDefns); /* check against previous defns */ - linkPreludeNames(); + if (!combined) linkPreludeNames(); /* link names in Prelude */ mapProc(checkForeignImport,foreignImports); /* check foreign imports */ mapProc(checkForeignExport,foreignExports); /* check foreign exports */ @@ -5268,11 +5270,12 @@ Int what; { #endif break; - case INSTALL : staticAnalysis(RESET); + case POSTPREL: break; + + case PREPREL : staticAnalysis(RESET); #if TREX extKind = pair(STAR,pair(ROW,ROW)); #endif - break; } } diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index f9c983b..ec0bbc9 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.24 $ - * $Date: 1999/12/07 11:14:57 $ + * $Revision: 1.25 $ + * $Date: 1999/12/10 15:59:53 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -578,20 +578,25 @@ List ts; { /* Null pattern matches every tycon*/ return ts; } -Text ghcTupleText(tup) -Tycon tup; { +Text ghcTupleText_n ( Int n ) +{ Int i; char buf[103]; - assert(isTuple(tup)); - tup = tupleOf(tup); - if (tup >= 100) internal("ghcTupleText"); + if (n < 0 || n >= 100) internal("ghcTupleText_n"); buf[0] = '('; - for (i = 1; i <= tup; i++) buf[i] = ','; + for (i = 1; i <= n; i++) buf[i] = ','; buf[i] = ')'; buf[i+1] = 0; return findText(buf); } +Text ghcTupleText(tup) +Tycon tup; { + assert(isTuple(tup)); + return ghcTupleText_n ( tupleOf(tup) ); +} + + Tycon mkTuple ( Int n ) { Int i; @@ -605,17 +610,16 @@ Tycon mkTuple ( Int n ) Void allocTupleTycon ( Int n ) { Int i; - char buf[20]; Kind k; Tycon t; for (i = TYCMIN; i < tyconHw; i++) if (tycon(i).tuple == n) return; - sprintf(buf,"Tuple%d",n); + //t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL); k = STAR; for (i = 0; i < n; i++) k = ap(STAR,k); - t = newTycon(findText(buf)); + t = newTycon(ghcTupleText_n(n)); tycon(t).kind = k; tycon(t).tuple = n; tycon(t).what = DATATYPE; @@ -1048,6 +1052,20 @@ Type tc; { || typeInvolves(arg(ty),tc))); } +Inst findSimpleInstance ( ConId klass, ConId dataty ) +{ + Inst in; + for (in = INSTMIN; in < instHw; in++) { + Cell head = inst(in).head; + if (isClass(fun(head)) + && cclass(fun(head)).text==textOf(klass) + && typeInvolves(arg(head), findTycon(textOf(dataty)) ) + ) + return in; + } + return NIL; +} + /* -------------------------------------------------------------------------- * Control stack: * @@ -1951,7 +1969,7 @@ Int depth; { Printf("Offset %d", offsetOf(c)); break; case TUPLE: - Printf("Tuple %d", tupleOf(c)); + Printf("%s", textToStr(ghcTupleText(tupleOf(c)))); break; case POLYTYPE: Printf("Polytype"); @@ -2083,6 +2101,10 @@ Int depth; { print(snd(c),depth-1); Putchar(')'); break; + case ZTUP2: + Printf("'); case BANG: Printf("(BANG,"); print(snd(c),depth-1); @@ -2480,6 +2502,133 @@ List xs; { /* non destructive */ return outs; } + +/* -------------------------------------------------------------------------- + * Strongly-typed lists (z-lists) and tuples (experimental) + * ------------------------------------------------------------------------*/ + +static void z_tag_check ( Cell x, int tag, char* caller ) +{ + char buf[100]; + if (isNull(x)) { + sprintf(buf,"z_tag_check(%s): null\n", caller); + internal(buf); + } + if (whatIs(x) != tag) { + sprintf(buf, + "z_tag_check(%s): tag was %d, expected %d\n", + caller, whatIs(x), tag ); + internal(buf); + } +} + +#if 0 +Cell zcons ( Cell x, Cell xs ) +{ + if (!(isNull(xs) || whatIs(xs)==ZCONS)) + internal("zcons: ill typed tail"); + return ap(ZCONS,ap(x,xs)); +} + +Cell zhd ( Cell xs ) +{ + if (isNull(xs)) internal("zhd: empty list"); + z_tag_check(xs,ZCONS,"zhd"); + return fst( snd(xs) ); +} + +Cell ztl ( Cell xs ) +{ + if (isNull(xs)) internal("ztl: empty list"); + z_tag_check(xs,ZCONS,"zhd"); + return snd( snd(xs) ); +} + +Int zlength ( ZList xs ) +{ + Int n = 0; + while (nonNull(xs)) { + z_tag_check(xs,ZCONS,"zlength"); + n++; + xs = snd( snd(xs) ); + } + return n; +} + +ZList zreverse ( ZList xs ) +{ + ZList rev = NIL; + while (nonNull(xs)) { + z_tag_check(xs,ZCONS,"zreverse"); + rev = zcons(zhd(xs),rev); + xs = ztl(xs); + } + return rev; +} + +Cell zsingleton ( Cell x ) +{ + return zcons (x,NIL); +} + +Cell zdoubleton ( Cell x, Cell y ) +{ + return zcons(x,zcons(y,NIL)); +} +#endif + +Cell zpair ( Cell x1, Cell x2 ) +{ return ap(ZTUP2,ap(x1,x2)); } +Cell zfst ( Cell zpair ) +{ z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); } +Cell zsnd ( Cell zpair ) +{ z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); } + +Cell ztriple ( Cell x1, Cell x2, Cell x3 ) +{ return ap(ZTUP3,ap(x1,ap(x2,x3))); } +Cell zfst3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); } +Cell zsnd3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); } +Cell zthd3 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); } + +Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 ) +{ return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); } +Cell zsel14 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); } +Cell zsel24 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); } +Cell zsel34 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); } +Cell zsel44 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); } + +Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 ) +{ return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); } +Cell zsel15 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); } +Cell zsel25 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); } +Cell zsel35 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); } +Cell zsel45 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); } +Cell zsel55 ( Cell zpair ) +{ z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); } + + +Cell unap ( int tag, Cell c ) +{ + char buf[100]; + if (whatIs(c) != tag) { + sprintf(buf, "unap: specified %d, actual %d\n", + tag, whatIs(c) ); + internal(buf); + } + return snd(c); +} + /* -------------------------------------------------------------------------- * Operations on applications: * ------------------------------------------------------------------------*/ @@ -2638,6 +2787,8 @@ Int what; { Int i; switch (what) { + case POSTPREL: break; + case RESET : clearStack(); /* the next 2 statements are particularly important @@ -2725,7 +2876,7 @@ Int what; { break; - case INSTALL : heapFst = heapAlloc(heapSize); + case PREPREL : heapFst = heapAlloc(heapSize); heapSnd = heapAlloc(heapSize); if (heapFst==(Heap)0 || heapSnd==(Heap)0) { diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 39d7c20..5fc0350 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.19 $ - * $Date: 1999/12/07 11:14:58 $ + * $Revision: 1.20 $ + * $Date: 1999/12/10 15:59:54 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -47,6 +47,9 @@ typedef Cell Float; /* floating pt literal */ typedef Cell Ext; /* extension label */ #endif +typedef Cell ConId; +typedef Cell VarId; + /* -------------------------------------------------------------------------- * Text storage: * provides storage for the characters making up identifier and symbol @@ -297,6 +300,7 @@ extern Ptr cptrOf Args((Cell)); #define PTRCELL 82 /* C Heap Pointer snd :: (Int,Int) */ #endif +/* STG syntax */ #define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */ #define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */ #define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */ @@ -305,13 +309,80 @@ extern Ptr cptrOf Args((Cell)); #define DEEFALT 97 /* DEEFALT snd :: (Var,Expr) */ #define CASEALT 98 /* CASEALT snd :: (Con,[Var],Expr) */ #define PRIMALT 99 /* PRIMALT snd :: ([Var],Expr) */ + + +/* + Top-level interface entities + type Line = Int -- a line number + type ConVarId = CONIDCELL | VARIDCELL + type = ZList a + type ExportListEntry = ConVarId | (ConId, ) + type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS + type Constr = (ConId, <(Type,VarId,Int)>) + (constr name, list of (type, field name if any, strictness)) + strictness: 0 => none, 1 => !, 2 => !! (unpacked) + All 2/3/4/5 tuples in the interface abstract syntax are done with + z-tuples. +*/ + +#define I_INTERFACE 109 /* snd :: (ConId, ) + interface name, list of iface entities */ + +#define I_IMPORT 110 /* snd :: (ConId, ) + module name, list of entities */ + +#define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */ + +#define I_EXPORT 112 /* snd :: (ConId, + this module name?, entities to export */ + +#define I_FIXDECL 113 /* snd :: (NIL|Int, Associativity, ConVarId) + fixity, associativity, name */ + +#define I_INSTANCE 114 /* snd :: (Line, <(QConId,VarId)>, Type, VarId) + lineno, + forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>), + other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an }, + name of dictionary builder */ + +#define I_TYPE 115 /* snd :: (Line, ConId, <(VarId,Kind)>, Type) + lineno, tycon, kinded tyvars, the type expr */ + +#define I_DATA 116 /* snd :: (Line, <(QConId,VarId)>, ConId, + <(VarId,Kind)>, ) + lineno, context, tycon, kinded tyvars, constrs */ + +#define I_NEWTYPE 117 /* snd :: (Line, <(QConId,VarId)>, ConId, + <(VarId,Kind)>, (ConId,Type)) + lineno, context, tycon, kinded tyvars, constr */ + +#define I_CLASS 118 /* snd :: (Line, <(QConId,VarId)>, ConId, + <(VarId,Kind)>, <(VarId,Type)>) + lineno, context, classname, + kinded tyvars, method sigs */ + +#define I_VALUE 119 /* snd :: (Line, VarId, Type) */ + + + +/* Generic syntax */ +#if 0 +#define ZCONS 190 /* snd :: (Cell,Cell) */ +#endif + + +#define ZTUP2 192 /* snd :: (Cell,Cell) */ +#define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */ +#define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */ +#define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */ + /* Last constructor tag must be less than SPECMIN */ /* -------------------------------------------------------------------------- * Special cell values: * ------------------------------------------------------------------------*/ -#define SPECMIN 101 +#define SPECMIN 201 #if TREX #define isSpec(c) (SPECMIN<=(c) && (c))"), - simpleKind(2),2, - DATATYPE,NIL); - typeList = addPrimTycon(findText("[]"), - starToStar,1, - DATATYPE,NIL); + setCurrModule(modulePrelude); - arrow = fn(aVar,bVar); - listof = ap(typeList,aVar); - boundPair = ap(ap(mkTuple(2),aVar),aVar); + starToStar = simpleKind(1); - nameUnit = addPrimCfun(findText("()"),0,0,typeUnit); - tycon(typeUnit).defn - = singleton(nameUnit); + typeUnit = addPrimTycon(findText("()"), + STAR,0,DATATYPE,NIL); + typeArrow = addPrimTycon(findText("(->)"), + simpleKind(2),2, + DATATYPE,NIL); + typeList = addPrimTycon(findText("[]"), + starToStar,1, + DATATYPE,NIL); - nameNil = addPrimCfun(findText("[]"),0,1, - mkPolyType(starToStar, - listof)); - nameCons = addPrimCfun(findText(":"),2,2, - mkPolyType(starToStar, - fn(aVar, - fn(listof, - listof)))); - name(nameNil).parent = - name(nameCons).parent = typeList; + arrow = fn(aVar,bVar); + listof = ap(typeList,aVar); + boundPair = ap(ap(mkTuple(2),aVar),aVar); - name(nameCons).syntax - = mkSyntax(RIGHT_ASS,5); + nameUnit = addPrimCfun(findText("()"),0,0,typeUnit); + tycon(typeUnit).defn + = singleton(nameUnit); - tycon(typeList).defn - = cons(nameNil,cons(nameCons,NIL)); + nameNil = addPrimCfun(findText("[]"),0,1, + mkPolyType(starToStar, + listof)); + nameCons = addPrimCfun(findText(":"),2,2, + mkPolyType(starToStar, + fn(aVar, + fn(listof, + listof)))); + name(nameNil).parent = + name(nameCons).parent = typeList; - typeVarToVar = fn(aVar,aVar); + name(nameCons).syntax + = mkSyntax(RIGHT_ASS,5); + + tycon(typeList).defn + = cons(nameNil,cons(nameCons,NIL)); + + typeVarToVar = fn(aVar,aVar); #if TREX - typeNoRow = addPrimTycon(findText("EmptyRow"), - ROW,0,DATATYPE,NIL); - typeRec = addPrimTycon(findText("Rec"), - pair(ROW,STAR),1, - DATATYPE,NIL); - nameNoRec = addPrimCfun(findText("EmptyRec"),0,0, - ap(typeRec,typeNoRow)); + typeNoRow = addPrimTycon(findText("EmptyRow"), + ROW,0,DATATYPE,NIL); + typeRec = addPrimTycon(findText("Rec"), + pair(ROW,STAR),1, + DATATYPE,NIL); + nameNoRec = addPrimCfun(findText("EmptyRec"),0,0, + ap(typeRec,typeNoRow)); #else - /* bogus definitions to avoid changing the prelude */ - addPrimCfun(findText("Rec"), 0,0,typeUnit); - addPrimCfun(findText("EmptyRow"), 0,0,typeUnit); - addPrimCfun(findText("EmptyRec"), 0,0,typeUnit); + /* bogus definitions to avoid changing the prelude */ + addPrimCfun(findText("Rec"), 0,0,typeUnit); + addPrimCfun(findText("EmptyRow"), 0,0,typeUnit); + addPrimCfun(findText("EmptyRec"), 0,0,typeUnit); #endif - break; + } + break; + } }