From: sewardj Date: Fri, 3 Dec 1999 12:39:48 +0000 (+0000) Subject: [project @ 1999-12-03 12:39:38 by sewardj] X-Git-Tag: Approximately_9120_patches~5439 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e3911d3448b4f63b7eedf9b68893c3a1c1fbbe2c;p=ghc-hetmet.git [project @ 1999-12-03 12:39:38 by sewardj] Add initial support for loading GHC Prelude (doesn't work yet): * Command line flag, +c/-c to start up in combined or standalone mode. In combined mode, looks for GHC's prelude in ghc/interpreter/GhcPrel (pro tem). * Parse unboxed tuple types and usage annotations in interface files. --- diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 7102d18..bb91b46 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.25 $ - * $Date: 1999/11/29 18:59:26 $ + * $Revision: 1.26 $ + * $Date: 1999/12/03 12:39:38 $ * ------------------------------------------------------------------------*/ #include @@ -106,15 +106,16 @@ static Void local browse Args((Void)); * Local data areas: * ------------------------------------------------------------------------*/ -static Bool printing = FALSE; /* TRUE => currently printing value*/ -static Bool showStats = FALSE; /* TRUE => print stats after eval */ -static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/ -static Bool addType = FALSE; /* TRUE => print type with value */ -static Bool useDots = RISCOS; /* TRUE => use dots in progress */ -static Bool quiet = FALSE; /* TRUE => don't show progress */ +static Bool printing = FALSE; /* TRUE => currently printing value*/ +static Bool showStats = FALSE; /* TRUE => print stats after eval */ +static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/ +static Bool addType = FALSE; /* TRUE => print type with value */ +static Bool useDots = RISCOS; /* TRUE => use dots in progress */ +static Bool quiet = FALSE; /* TRUE => don't show progress */ static Bool lastWasObject = FALSE; Bool preludeLoaded = FALSE; Bool debugSC = FALSE; + Bool combined = TRUE; //FALSE; typedef struct { @@ -339,9 +340,15 @@ String argv[]; { #endif if (haskell98) { - Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n"); + Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n"); } else { - Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n"); + Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n"); + } + + if (combined) { + Printf("Combined mode: Restart with command line -c for standalone mode\n\n" ); + } else { + Printf("Standalone mode: Restart with command line +c for combined mode\n\n" ); } everybody(INSTALL); @@ -572,6 +579,15 @@ String s; { /* return FALSE if none found. */ case 'h' : setHeapSize(s+1); return TRUE; + case 'c' : if (heapBuilt()) { + FPrintf(stderr, + "You can't enable/disable combined" + " operation inside Hugs\n" ); + } else { + combined = state; + } + return TRUE; + case 'D' : /* hack */ { extern void setRtsFlags( int x ); @@ -610,7 +626,7 @@ String s; { #if USE_REGISTRY FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n"); #else - FPrintf(stderr,"Cannot change heap size\n"); + FPrintf(stderr,"You cannot change heap size from inside Hugs\n"); #endif } else { heapSize = hpSize; @@ -770,11 +786,6 @@ struct options toggle[] = { /* List of command line toggles */ {'D', 1, "Debug: show generated G code", &debugCode}, #endif {'S', 1, "Debug: show generated SC code", &debugSC}, -#if 0 - {'f', 1, "Terminate evaluation on first error", &failOnError}, - {'u', 1, "Use \"show\" to display results", &useShow}, - {'i', 1, "Chase imports while loading modules", &chaseImports}, -#endif {0, 0, 0, 0} }; @@ -871,9 +882,13 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) /* 11 Oct 99: disable object loading in the interim. Will probably only reinstate when HEP becomes available. */ - fromObj = sAvail + if (combined) { + fromObj = sAvail ? (oAvail && iAvail && timeEarlier(sTime,oTime)) : TRUE; + } else { + fromObj = FALSE; + } /* ToDo: namesUpto overflow */ ent->modName = strCopy(iname); @@ -893,12 +908,12 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) static Void nukeEnding( String s ) { Int l = strlen(s); - if (l > 2 && strncmp(s+l-2,".o" ,3)==0) s[l-2] = 0; else - if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 0; else - if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else - if (l > 4 && strncmp(s+l-4,".lhs",4)==0) s[l-4] = 0; else - if (l > 4 && strncmp(s+l-4,".dll",4)==0) s[l-4] = 0; else - if (l > 4 && strncmp(s+l-4,".DLL",4)==0) s[l-4] = 0; + if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else + if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else + if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else + if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else + if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else + if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0; } static Void local addStackEntry(s) /* Add script to list of scripts */ @@ -948,7 +963,7 @@ Int stacknum; { strcat(name, scriptInfo[stacknum].modName); if (scriptInfo[stacknum].fromSource) strcat(name, scriptInfo[stacknum].srcExt); else - strcat(name, ".hi"); + strcat(name, ".u_hi"); scriptFile = name; @@ -1143,7 +1158,7 @@ Int n; { /* loading everything after and */ strcat(name, scriptInfo[n].modName); if (scriptInfo[n].fromSource) strcat(name, scriptInfo[n].srcExt); else - strcat(name, ".hi"); //ToDo: should be .o + strcat(name, ".u_hi"); //ToDo: should be .o getFileInfo(name,&timeStamp, &fileSize); if (timeChanged(timeStamp,scriptInfo[n].lastChange)) { dropScriptsFrom(n-1); diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 501b5c7..d47f684 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: input.c,v $ - * $Revision: 1.15 $ - * $Date: 1999/12/01 11:50:34 $ + * $Revision: 1.16 $ + * $Date: 1999/12/03 12:39:39 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -147,7 +147,7 @@ static Text textWildcard; static Text textModule, textImport, textInterface, textInstImport; static Text textHiding, textQualified, textAsMod; static Text textExport, textDynamic, textUUExport; -static Text textUnsafe, textUUAll; +static Text textUnsafe, textUUAll, textUUUsage; Text textCcall; /* ccall */ Text textStdcall; /* stdcall */ @@ -253,7 +253,7 @@ static Void local initCharTab() { /* Initialize char decode table */ * * At the lowest level of input, characters are read one at a time, with the * current character held in c0 and the following (lookahead) character in - * c1. The corrdinates of c0 within the file are held in (column,row). + * c1. The coordinates of c0 within the file are held in (column,row). * The input stream is advanced by one character using the skip() function. * ------------------------------------------------------------------------*/ @@ -1400,6 +1400,9 @@ static Int local yylex() { /* Read next input token ... */ * Now try to identify token type: * --------------------------------------------------------------------*/ + if (c0 == '(' && c1 == '#') { skip(); skip(); return UTL; }; + if (c0 == '#' && c1 == ')') { skip(); skip(); return UTR; }; + switch (c0) { case EOF : return 0; /* End of file/input */ @@ -1522,6 +1525,7 @@ static Int local yylex() { /* Read next input token ... */ if (it==textDlet && !haskell98) lookAhead(DLET); #endif if (it==textUUAll) return ALL; + if (it==textUUUsage) return UUUSAGE; if (it==textRepeat && reading==KEYBOARD) return repeatLast(); @@ -1742,6 +1746,7 @@ Int what; { textWildcard = findText("_"); textAll = findText("forall"); textUUAll = findText("__forall"); + textUUUsage = findText("__u"); varMinus = mkVar(textMinus); varPlus = mkVar(textPlus); varBang = mkVar(textBang); diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 2be1e61..6eed036 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -7,8 +7,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: interface.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/11/29 18:59:28 $ + * $Revision: 1.8 $ + * $Date: 1999/12/03 12:39:40 $ * ------------------------------------------------------------------------*/ /* ToDo: @@ -34,8 +34,8 @@ #include "Assembler.h" /* for wrapping GHC objects */ #include "dynamic.h" -#define DEBUG_IFACE -#define VERBOSITY TRUE +// #define DEBUG_IFACE +#define VERBOSE FALSE extern void print ( Cell, Int ); @@ -365,7 +365,7 @@ Module mod; { } // Last, but by no means least ... - resolveReferencesInObjectModule ( mod, FALSE ); + resolveReferencesInObjectModule ( mod, TRUE ); } Void openGHCIface(t) @@ -376,7 +376,7 @@ Text t; { Module m = findModule(t); if (isNull(m)) { m = newModule(t); -printf ( "new module %s\n", textToStr(t) ); + //printf ( "new module %s\n", textToStr(t) ); } else if (m != modulePrelude) { ERRMSG(0) "Module \"%s\" already loaded", textToStr(t) EEND; @@ -404,7 +404,7 @@ printf ( "new module %s\n", textToStr(t) ); ERRMSG(0) "Read of object file \"%s\" failed", nameObj EEND; } - if (!validateOImage(img,sizeObj,VERBOSITY)) { + if (!validateOImage(img,sizeObj,VERBOSE)) { ERRMSG(0) "Validation of object file \"%s\" failed", nameObj EEND; } @@ -412,7 +412,7 @@ printf ( "new module %s\n", textToStr(t) ); assert(!module(m).oImage); module(m).oImage = img; - readSyms(m,VERBOSITY); + readSyms(m,VERBOSE); if (!cellIsMember(m, ghcModules)) ghcModules = cons(m, ghcModules); @@ -816,17 +816,17 @@ Cell constr; { /* (ConId,Type) */ } } -Void addGHCClass(line,ctxt,tc_name,tv,mems0) +Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0) Int line; List ctxt; /* [(QConId, VarId)] */ Cell tc_name; /* ConId */ -Text tv; /* VarId */ +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, tv); + Pair newCtx = pair(tc_name, fst(kinded_tv)); # ifdef DEBUG_IFACE printf ( "\nbegin addGHCclass %s\n", textToStr(ct) ); # endif @@ -850,9 +850,13 @@ List mems0; { /* [(VarId, Type)] */ /* Kludge to map the single tyvar in the context to Offset 0. Need to do something better for multiparam type classes. - */ + cclass(nw).supers = tvsToOffsets(line,ctxt, singleton(pair(tv,STAR))); + */ + cclass(nw).supers = tvsToOffsets(line,ctxt, + singleton(kinded_tv)); + for (mems=mems0; nonNull(mems); mems=tl(mems)) { Pair mem = hd(mems); @@ -946,7 +950,7 @@ static Void local finishGHCClass(Class nw) Void addGHCInstance (line,ctxt0,cls,var) Int line; List ctxt0; /* [(QConId, Type)] */ -Pair cls; /* (ConId, [Type]) */ +List cls; /* [(ConId, Type)] */ Text var; { /* Text */ List tmp, tvs, ks; Inst in = newInst(); @@ -955,7 +959,9 @@ Text var; { /* Text */ # endif /* Make tvs into a list of tyvars with bogus kinds. */ - tvs = nubList(ifTyvarsIn(snd(cls))); + //print ( cls, 10 ); printf ( "\n"); + tvs = nubList(ifTyvarsIn(cls)); + //print ( tvs, 10 ); ks = NIL; for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) { hd(tmp) = pair(hd(tmp),STAR); @@ -1044,6 +1050,8 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ tvsToOffsets(line,snd(snd(type)),ktyvars))); case DICTAP: /* bogus ?? */ return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars)); + case UNBOXEDTUP: /* bogus?? */ + return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars)); case VARIDCELL: /* Ha! some real work to do! */ { Int i = 0; Text tv = textOf(type); @@ -1066,6 +1074,16 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ return NIL; /* NOTREACHED */ } +/* ToDo: nuke this */ +static Text kludgeGHCPrelText ( Text m ) +{ + return m; +#if 0 + if (strncmp(textToStr(m), "Prel", 4)==0) + return textPrelude; else return m; +#endif +} + /* This is called from the finishGHC* functions. It traverses a structure and converts conidcells, ie, type constructors parsed by the interface @@ -1075,11 +1093,6 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ Tycons or Classes have been loaded into the symbol tables and can be looked up. */ -static Text kludgeGHCPrelText ( Text m ) -{ - if (strncmp(textToStr(m), "Prel", 4)==0) - return textPrelude; else return m; -} static Type local conidcellsToTycons(line,type) Int line; @@ -1141,6 +1154,8 @@ Type type; { conidcellsToTycons(line,snd(snd(type))))); case DICTAP: /* bogus?? */ return ap(DICTAP, conidcellsToTycons(line, snd(type))); + case UNBOXEDTUP: + return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type))); default: fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n", whatIs(type)); @@ -1267,7 +1282,7 @@ static Void local resolveReferencesInObjectModule_elf ( Module m, Elf32_Word* targ; // first find "the" symbol table // why is this commented out??? - stab = findElfSection ( ehdrC, SHT_SYMTAB ); + stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB ); // also go find the string table strtab = findElfSection ( ehdrC, SHT_STRTAB ); @@ -1548,7 +1563,8 @@ static void readSyms_elf ( Module m, Bool verb ) ) && ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC || - ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT ) + ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT || + ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE) ) { char* nm = strtab + stab[j].st_name; char* ad = ehdrC @@ -1561,6 +1577,7 @@ static void readSyms_elf ( Module m, Bool verb ) ad, textToStr(module(m).text), nm ); addOTabName ( m, nm, ad ); } + //else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name ); } } @@ -1616,16 +1633,22 @@ extern int stg_update_PAP; extern int __ap_2_upd_info; extern int MainRegTable; extern int Upd_frame_info; +extern int CAF_BLACKHOLE_info; +extern int IND_STATIC_info; +extern int newCAF; OSym rtsTab[] = { - { "stg_gc_enter_1", &stg_gc_enter_1 }, - { "stg_chk_0", &stg_chk_0 }, - { "stg_chk_1", &stg_chk_1 }, - { "stg_update_PAP", &stg_update_PAP }, - { "__ap_2_upd_info", &__ap_2_upd_info }, - { "MainRegTable", &MainRegTable }, - { "Upd_frame_info", &Upd_frame_info }, + { "stg_gc_enter_1", &stg_gc_enter_1 }, + { "stg_chk_0", &stg_chk_0 }, + { "stg_chk_1", &stg_chk_1 }, + { "stg_update_PAP", &stg_update_PAP }, + { "__ap_2_upd_info", &__ap_2_upd_info }, + { "MainRegTable", &MainRegTable }, + { "Upd_frame_info", &Upd_frame_info }, + { "CAF_BLACKHOLE_info", &CAF_BLACKHOLE_info }, + { "IND_STATIC_info", &IND_STATIC_info }, + { "newCAF", &newCAF }, {0,0} }; @@ -1652,7 +1675,7 @@ void* lookupObjName ( char* nm ) pp = strchr(nm2, '_'); if (!pp) goto not_found; *pp = 0; - t = unZcodeThenFindText(nm2); + t = kludgeGHCPrelText( unZcodeThenFindText(nm2) ); m = findModule(t); if (isNull(m)) goto not_found; a = lookupOTabName ( m, nm ); diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index be3eab2..ace1420 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.14 $ - * $Date: 1999/11/25 10:19:16 $ + * $Revision: 1.15 $ + * $Date: 1999/12/03 12:39:42 $ * ------------------------------------------------------------------------*/ #ifdef HAVE_SIGNAL_H @@ -221,7 +221,7 @@ String f; { return (0 == access(f,4)); #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H struct stat scbuf; - //fprintf(stderr, "readable: %s\n", f ); + /* fprintf(stderr, "readable: %s\n", f ); */ return ( !stat(f,&scbuf) && (scbuf.st_mode & S_IREAD) /* readable */ && (scbuf.st_mode & S_IFREG) /* regular file */ @@ -256,18 +256,21 @@ static Bool local tryEndings Args((String)); # define SLASH '\\' # define isSLASH(c) ((c)=='\\' || (c)=='/') # define PATHSEP ';' +# define PATHSEP_STR ";" # define DLL_ENDING ".dll" #elif MAC_FILENAMES # define SLASH ':' # define isSLASH(c) ((c)==SLASH) # define PATHSEP ';' +# define PATHSEP_STR ";" /* Mac PEF (Preferred Executable Format) file */ # define DLL_ENDING ".pef" #else # define SLASH '/' # define isSLASH(c) ((c)==SLASH) # define PATHSEP ':' -# define DLL_ENDING ".o" +# define PATHSEP_STR ":" +# define DLL_ENDING ".u_o" #endif static String local hugsdir() { /* directory containing lib/Prelude.hs */ @@ -380,9 +383,9 @@ String s; { /* a pathname in some appropriate manner. */ } #if HSCRIPT -static String endings[] = { "", ".hi", ".hs", ".lhs", ".hsx", ".hash", 0 }; +static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 }; #else -static String endings[] = { "", ".hi", ".hs", ".lhs", 0 }; +static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 }; #endif static char searchBuf[FILENAME_MAX+1]; static Int searchPos; @@ -660,23 +663,33 @@ Bool findFilesForModule ( Int nPath; Bool literate; String peStart, peEnd; - String augdPath; /* .:hugsPath:installDir/lib */ + String augdPath; /* .:hugsPath:installDir/GhcPrel:installDir/lib */ *path = *sExt = NULL; *sAvail = *iAvail = *oAvail = FALSE; *sSize = *iSize = *oSize = 0; - augdPath = malloc(4+3+strlen(installDir)+strlen(hugsPath)); + augdPath = malloc( 2*(10+3+strlen(installDir)) + +strlen(hugsPath) +10/*paranoia*/); if (!augdPath) internal("moduleNameToFileNames: malloc failed(2)"); - augdPath[0] = '.'; - augdPath[1] = PATHSEP; - augdPath[2] = 0; - strcat ( augdPath, hugsPath ); - augdPath[2+strlen(hugsPath)] = PATHSEP; - augdPath[3+strlen(hugsPath)] = 0; - strcat(augdPath,installDir); - strcat(augdPath,"lib"); + + augdPath[0] = 0; + strcat(augdPath, "."); + strcat(augdPath, PATHSEP_STR); + + strcat(augdPath, hugsPath); + strcat(augdPath, PATHSEP_STR); + + strcat(augdPath, installDir); + strcat(augdPath, "GhcPrel"); + strcat(augdPath, PATHSEP_STR); + + strcat(augdPath, installDir); + strcat(augdPath, "lib"); + strcat(augdPath, PATHSEP_STR); + + /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */ peEnd = augdPath-1; while (1) { @@ -717,7 +730,7 @@ Bool findFilesForModule ( getFileInfo(searchBuf, oTime, oSize); } - strcpy(searchBuf+nPath, ".hi"); + strcpy(searchBuf+nPath, ".u_hi"); if (readable(searchBuf)) { *iAvail = TRUE; getFileInfo(searchBuf, iTime, iSize); diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 0ca0fa6..8073580 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.15 $ - * $Date: 1999/11/29 18:53:14 $ + * $Revision: 1.16 $ + * $Date: 1999/12/03 12:39:42 $ * ------------------------------------------------------------------------*/ %{ @@ -98,6 +98,7 @@ static Void local noIP Args((String)); %token TMODULE IMPORT HIDING QUALIFIED ASMOD %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE %token INSTIMPORT DYNAMIC CCALL STDKALL +%token UTL UTR UUUSAGE %% /*- Top level script/module structure -------------------------------------*/ @@ -134,13 +135,17 @@ varid_or_conid opt_bang : '!' {$$=gc1(NIL);} | {$$=gc0(NIL);} ; +opt_COCO : COCO {$$=gc1(NIL);} + | {$$=gc0(NIL);} + ; + ifName : CONID {openGHCIface(textOf($1)); $$ = gc1(NIL);} checkVersion : NUMLIT {$$ = gc1(NIL); } ; ifDecl - : IMPORT CONID NUMLIT opt_bang COCO version_list_junk + : IMPORT CONID NUMLIT opt_bang opt_COCO version_list_junk { addGHCImports(intOf($3),textOf($2), $6); $$ = gc6(NIL); @@ -161,7 +166,7 @@ ifDecl {$$ = gc4(fixdecl($2,singleton($4), NON_ASS,$3)); } - | TINSTANCE ifCtxInst ifInstHd '=' ifVar + | TINSTANCE ifCtxInst ifInstHdL '=' ifVar { addGHCInstance(intOf($1),$2,$3, textOf($5)); $$ = gc5(NIL); } @@ -178,7 +183,7 @@ ifDecl { addGHCNewType(intOf($2), $3,$4,$5,$6); $$ = gc6(NIL); } - | NUMLIT TCLASS ifCtxDecl ifCon ifTyvar ifCmeths + | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths { addGHCClass(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); } | NUMLIT ifVar COCO ifType @@ -222,11 +227,18 @@ ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} => */ | ALL ifForall IMPLIES {$$=gc3(NIL);} | {$$=gc0(NIL);} ; -ifInstHd /* { Class aType } :: (ConId, Type) */ - : '{' ifCon ifAType '}' {$$=gc4(pair($2,$3));} +ifInstHd /* { Class aType } :: (ConId, Type) */ + : '{' ifCon ifAType '}' {$$=gc4(ap(DICTAP,pair($2,singleton($3))));} + ; + +ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: [(ConId, Type)] */ + /* Note: not constructing the list with fn($1,$3) */ + : ifInstHd ARROW ifInstHdL {$$=gc3(fn($1,$3));} + | ifInstHd {$$=gc1(NIL);} ; -ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ + +ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */ : { $$ = gc0(NIL); } | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); } ; @@ -308,29 +320,48 @@ ifType : ALL ifForall ifCtxDeclT IMPLIES ifType | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); } | ifBType { $$ = gc1($1); } ; -ifForall /* [(VarId,Kind)] */ +ifForall /* [(VarId,Kind)] */ : '[' ifKindedTyvarL ']' { $$ = gc3($2); } - ; -ifTypes2 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } - | ifType ',' ifTypes2 { $$ = gc3(cons($1,$3)); } ; + +ifTypeL2 /* [Type], 2 or more */ + : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } + | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); } + ; + +ifTypeL /* [Type], 0 or more */ + : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); } + | ifType { $$ = gc1(singleton($1)); } + | { $$ = gc0(NIL); } + ; + ifBType : ifAType { $$ = gc1($1); } | ifBType ifAType { $$ = gc2(ap($1,$2)); } + | UUUSAGE ifUsage ifAType { $$ = gc3($3); } ; + ifAType : ifQTCName { $$ = gc1($1); } | ifTyvar { $$ = gc1($1); } | '(' ')' { $$ = gc2(typeUnit); } - | '(' ifTypes2 ')' { $$ = gc3(buildTuple($2)); } + | '(' ifTypeL2 ')' { $$ = gc3(buildTuple($2)); } | '[' ifType ']' { $$ = gc3(ap(typeList,$2));} | '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP, pair($2,$3))); } | '(' ifType ')' { $$ = gc3($2); } + | UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); } ; ifATypes : { $$ = gc0(NIL); } | ifAType ifATypes { $$ = gc2(cons($1,$2)); } ; +/*- KW's usage stuff --------------------------------------*/ +ifUsage : '-' { $$ = gc1(NIL); } + | '!' { $$ = gc1(NIL); } + | ifVar { $$ = gc1(NIL); } + ; + + /*- Interface kinds ---------------------------------------*/ ifKindedTyvarL /* [(VarId,Kind)] */ : { $$ = gc0(NIL); } diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 282650d..33dc2ee 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.18 $ - * $Date: 1999/11/29 18:59:30 $ + * $Revision: 1.19 $ + * $Date: 1999/12/03 12:39:44 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1758,7 +1758,11 @@ Cell ty; /* used in type expression, reading*/ List us; /* from left to right ignoring any */ List ws; /* listed in us. */ List vs; { /* ws = explicitly quantified vars */ + if (isNull(ty)) return vs; switch (whatIs(ty)) { + case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs); + case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs); + case AP : return typeVarsIn(snd(ty),us,ws, typeVarsIn(fst(ty),us,ws,vs)); @@ -1785,8 +1789,14 @@ List vs; { /* ws = explicitly quantified vars */ } return vs; } + case TUPLE: + case TYCON: + case CONIDCELL: + case QUALIDENT: return vs; + + default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn"); } - return vs; + assert(0); } static List local maybeAppendVar(v,vs) /* append variable to list if not */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 93c4dd4..c705286 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.19 $ - * $Date: 1999/11/29 18:59:32 $ + * $Revision: 1.20 $ + * $Date: 1999/12/03 12:39:46 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -390,6 +390,23 @@ Text enZcodeThenFindText ( String s ) } +Text textOf ( Cell c ) +{ + Bool ok = + (whatIs(c)==VARIDCELL + || whatIs(c)==CONIDCELL + || whatIs(c)==VAROPCELL + || whatIs(c)==CONOPCELL + || whatIs(c)==STRCELL + || whatIs(c)==DICTVAR + ); + if (!ok) { + fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) ); + internal("textOf: bad tag"); + } + return snd(c); +} + /* -------------------------------------------------------------------------- * Ext storage: * @@ -1239,7 +1256,7 @@ void* lookupOTabName ( Module m, char* nm ) { int i; for (i = 0; i < module(m).usedoTab; i++) { - if (0) + if (1) fprintf ( stderr, "lookupOTabName: request %s, table has %s\n", nm, module(m).oTab[i].nm ); @@ -2021,6 +2038,16 @@ Int depth; { print(snd(snd(c)),depth-1); Putchar(')'); break; + case DICTAP: + Printf("(DICTAP,"); + print(snd(c),depth-1); + Putchar(')'); + break; + case UNBOXEDTUP: + Printf("(UNBOXEDTUP,"); + print(snd(c),depth-1); + Putchar(')'); + break; default: if (isBoxTag(tag)) { Printf("Tag(%d)=%d", c, tag); diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 568c25c..9d127b4 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.14 $ - * $Date: 1999/11/29 18:59:34 $ + * $Revision: 1.15 $ + * $Date: 1999/12/03 12:39:48 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -164,27 +164,6 @@ extern Cell whatIs Args((Cell)); #define EXTCOPY 22 /* Copy of an Ext: snd :: Text */ #endif -//#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */ - -#if 1 -static Text textOf( Cell c ) -{ - Bool ok = - (whatIs(c)==VARIDCELL - || whatIs(c)==CONIDCELL - || whatIs(c)==VAROPCELL - || whatIs(c)==CONOPCELL - || whatIs(c)==STRCELL - || whatIs(c)==DICTVAR - ); - if (!ok) { -fprintf(stderr, "\ntextOf -- tag %d\n",whatIs(c) ); - assert(ok); - } - return snd(c); -} -#endif - #define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */ #define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */ #define mkVar(t) ap(VARIDCELL,t) @@ -208,14 +187,15 @@ fprintf(stderr, "\ntextOf -- tag %d\n",whatIs(c) ); #else #define isIP(p) FALSE #endif -extern Bool isVar Args((Cell)); -extern Bool isCon Args((Cell)); -extern Bool isQVar Args((Cell)); -extern Bool isQCon Args((Cell)); -extern Bool isQualIdent Args((Cell)); -extern Bool isIdent Args((Cell)); -extern String stringNegate Args((String)); +extern Bool isVar Args((Cell)); +extern Bool isCon Args((Cell)); +extern Bool isQVar Args((Cell)); +extern Bool isQCon Args((Cell)); +extern Bool isQualIdent Args((Cell)); +extern Bool isIdent Args((Cell)); +extern String stringNegate Args((String)); +extern Text textOf Args((Cell)); #define isFloat(c) (isPair(c) && fst(c)==FLOATCELL) #define stringToFloat(s) pair(FLOATCELL,findText(s)) @@ -227,7 +207,6 @@ extern String stringNegate Args((String)); #define stringToBignum(s) pair(BIGCELL,findText(s)) #define bignumToString(b) textToStr(snd(b)) - #if PTR_ON_HEAP #define isPtr(c) (isPair(c) && fst(c)==PTRCELL) extern Cell mkPtr Args((Ptr)); @@ -311,10 +290,11 @@ extern Ptr cptrOf Args((Cell)); #define NEG 79 /* NEG snd :: Exp */ /* Used when parsing GHC interface files */ -#define DICTAP 80 /* DICTTYPE snd :: (QClassId,[Type]) */ +#define DICTAP 80 /* DICTAP snd :: (QClassId,[Type]) */ +#define UNBOXEDTUP 81 /* UNBOXEDTUP snd :: [Type] */ #if SIZEOF_INTP != SIZEOF_INT -#define PTRCELL 81 /* C Heap Pointer snd :: (Int,Int) */ +#define PTRCELL 82 /* C Heap Pointer snd :: (Int,Int) */ #endif #define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */