From b3c8ae4e104c93354738d3992fcf0e60e9646490 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 29 Nov 1999 18:59:46 +0000 Subject: [PATCH] [project @ 1999-11-29 18:59:23 by sewardj] Make StgHugs use the same naming scheme as GHC does for class + instance machinery. Add machinery to do Z-encoding/decoding of names extracted from interface files. Make the ELF object loader work again. It seemed to have suffered slight bitrot over the past couple of months. Fix various minor bugs. Track a small change in interface file syntax. Make Printer.c print tagged-unboxed stack sections in a decent way now that Alastair-style stack tags have been abandoned. --- ghc/includes/Assembler.h | 22 ++--- ghc/includes/options.h | 7 +- ghc/interpreter/codegen.c | 12 +-- ghc/interpreter/connect.h | 11 +-- ghc/interpreter/hugs.c | 18 ++--- ghc/interpreter/input.c | 61 +++++++------- ghc/interpreter/interface.c | 48 +++++++---- ghc/interpreter/lift.c | 17 ++-- ghc/interpreter/output.c | 20 +++-- ghc/interpreter/static.c | 29 ++++--- ghc/interpreter/stg.c | 6 +- ghc/interpreter/storage.c | 187 ++++++++++++++++++++++++++++++++++++++++++- ghc/interpreter/storage.h | 21 +++-- ghc/interpreter/type.c | 54 +++++++++++-- ghc/interpreter/version.h | 2 +- ghc/rts/Assembler.c | 25 +++--- ghc/rts/Evaluator.c | 13 +-- ghc/rts/Printer.c | 8 +- 18 files changed, 416 insertions(+), 145 deletions(-) diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index ce553f4..1d5c7db 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Assembler.h,v 1.11 1999/11/16 17:38:54 sewardj Exp $ + * $Id: Assembler.h,v 1.12 1999/11/29 18:59:23 sewardj Exp $ * * (c) The GHC Team 1994-1998. * @@ -203,12 +203,14 @@ typedef struct { AsmNat8 opcode; /* should be Primop1 or Primop2 */ } AsmPrim; -extern const AsmPrim asmPrimOps[]; /* null terminated list */ +extern AsmPrim asmPrimOps[]; /* null terminated list */ -extern const AsmPrim* asmFindPrim ( char* s ); -extern const AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op ); -extern AsmSp asmBeginPrim ( AsmBCO bco ); -extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base ); +extern AsmPrim* asmFindPrim ( char* s ); +extern AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op ); +extern AsmSp asmBeginPrim ( AsmBCO bco ); +extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, + AsmSp base ); +extern char* asmGetPrimopName ( AsmPrim* p ); extern AsmBCO asm_BCO_catch ( void ); extern AsmBCO asm_BCO_raise ( void ); @@ -243,10 +245,10 @@ extern void asmEndMkPAP ( AsmBCO bco, AsmVar v, AsmSp start ); * C-call and H-call * ------------------------------------------------------------------------*/ -extern const AsmPrim ccall_ccall_Id; -extern const AsmPrim ccall_ccall_IO; -extern const AsmPrim ccall_stdcall_Id; -extern const AsmPrim ccall_stdcall_IO; +extern AsmPrim ccall_ccall_Id; +extern AsmPrim ccall_ccall_IO; +extern AsmPrim ccall_stdcall_Id; +extern AsmPrim ccall_stdcall_IO; typedef struct { unsigned int num_args; diff --git a/ghc/includes/options.h b/ghc/includes/options.h index aec07a7..6b385de 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -13,8 +13,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: options.h,v $ - * $Revision: 1.13 $ - * $Date: 1999/11/22 16:44:31 $ + * $Revision: 1.14 $ + * $Date: 1999/11/29 18:59:23 $ * ------------------------------------------------------------------------*/ @@ -311,9 +311,6 @@ /* Define if debugging generated bytecodes or the bytecode interpreter */ #define DEBUG_CODE 1 -/* Define if debugging generated supercombinator definitions or compiler */ -#define DEBUG_SHOWSC 0 - /* Define if you want to use a low-level printer from within a debugger */ #define DEBUG_PRINTER 1 diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c index 045be41..2ffd55a 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.11 $ - * $Date: 1999/11/22 18:11:00 $ + * $Revision: 1.12 $ + * $Date: 1999/11/29 18:59:25 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -63,7 +63,8 @@ static Cell cptrFromName ( Name n ) Module m = name(n).mod; Text mt = module(m).text; sprintf(buf,"%s_%s_closure", - textToStr(mt), textToStr(name(n).text) ); + textToStr(mt), + textToStr( enZcodeThenFindText ( textToStr (name(n).text) ) ) ); p = lookupOTabName ( m, buf ); if (!p) { ERRMSG(0) "Can't find object symbol %s", buf @@ -205,7 +206,7 @@ static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts ) con = stgCaseAltCon(hd(alts)); /* special case: dictionary constructors */ - if (strncmp("Make.",textToStr(name(con).text),5)==0) { + if (strncmp(":D",textToStr(name(con).text),2)==0) { omit_test = TRUE; goto xyzzy; } @@ -389,7 +390,8 @@ static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e ) } else { /* ToDo: implement this code... */ assert(0); - /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), stgPrimCaseBody(e))); */ + /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e), + stgPrimCaseBody(e))); */ /* cgExpr( bco,root,scrut ); */ } break; diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index f956c6d..9b0603e 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.18 $ - * $Date: 1999/11/25 10:19:15 $ + * $Revision: 1.19 $ + * $Date: 1999/11/29 18:59:25 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -171,10 +171,7 @@ extern String preprocessor; /* preprocessor command */ #if DEBUG_CODE extern Bool debugCode; /* TRUE => print G-code to screen */ #endif -#if DEBUG_SHOWSC extern Bool debugSC; /* TRUE => print SC to screen */ -extern Void printSc Args((FILE*, Text, Int, Cell)); -#endif extern Bool kindExpert; /* TRUE => display kind errors in */ /* full detail */ extern Bool allowOverlap; /* TRUE => allow overlapping insts */ @@ -314,6 +311,9 @@ extern Inst findInstFor Args((Cell,Int)); extern List findInstsFor Args((Cell,Int)); #endif +extern Void ppScripts ( Void ); +extern Void ppModules ( Void ); + extern Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds ); #define aVar mkOffset(0) /* Simple skeleton for type var */ @@ -541,6 +541,7 @@ extern Int outColumn; /* current output column number */ extern Void unlexStrConst Args((Text)); extern Void unlexVar Args((Text)); +extern Void unlexVarStr Args((String)); extern List offsetTyvarsIn Args((Type,List)); extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index f1272c6..7102d18 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.24 $ - * $Date: 1999/11/25 10:19:16 $ + * $Revision: 1.25 $ + * $Date: 1999/11/29 18:59:26 $ * ------------------------------------------------------------------------*/ #include @@ -29,7 +29,7 @@ #include "Rts.h" #include "RtsAPI.h" #include "Schedule.h" - +#include "Assembler.h" /* DEBUG_LoadSymbols */ Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/ @@ -108,12 +108,13 @@ static Void local browse Args((Void)); 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 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; typedef struct { @@ -768,9 +769,7 @@ struct options toggle[] = { /* List of command line toggles */ #if DEBUG_CODE {'D', 1, "Debug: show generated G code", &debugCode}, #endif -#if DEBUG_SHOWSC {'S', 1, "Debug: show generated SC code", &debugSC}, -#endif #if 0 {'f', 1, "Terminate evaluation on first error", &failOnError}, {'u', 1, "Use \"show\" to display results", &useShow}, @@ -860,8 +859,8 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) ); if (!ok) { ERRMSG(0) - /* "Can't file source or object+interface for module \"%s\"", */ - "Can't file source for module \"%s\"", + "Can't find source or object+interface for module \"%s\"", + /* "Can't find source for module \"%s\"", */ iname EEND; } @@ -871,11 +870,10 @@ static Void local makeStackEntry ( ScriptInfo* ent, String iname ) /* Load objects in preference to sources if both are available */ /* 11 Oct 99: disable object loading in the interim. Will probably only reinstate when HEP becomes available. + */ fromObj = sAvail ? (oAvail && iAvail && timeEarlier(sTime,oTime)) : TRUE; - */ - fromObj = FALSE; /* ToDo: namesUpto overflow */ ent->modName = strCopy(iname); diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index bab8fa7..82ca236 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.13 $ - * $Date: 1999/11/25 11:10:16 $ + * $Revision: 1.14 $ + * $Date: 1999/11/29 18:59:27 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -49,25 +49,26 @@ * Global data: * ------------------------------------------------------------------------*/ -List tyconDefns = NIL; /* type constructor definitions */ -List typeInDefns = NIL; /* type synonym restrictions */ -List valDefns = NIL; /* value definitions in script */ -List classDefns = NIL; /* class defns in script */ -List instDefns = NIL; /* instance defns in script */ -List selDefns = NIL; /* list of selector lists */ -List genDefns = NIL; /* list of generated names */ -List unqualImports = NIL; /* unqualified import list */ -List foreignImports = NIL; /* foreign imports */ -List foreignExports = NIL; /* foreign exportsd */ -List defaultDefns = NIL; /* default definitions (if any) */ -Int defaultLine = 0; /* line in which default defs occur*/ -List evalDefaults = NIL; /* defaults for evaluator */ - -Cell inputExpr = NIL; /* input expression */ -Cell inputContext = NIL; /* input context */ -Bool literateScripts = FALSE; /* TRUE => default to lit scripts */ -Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */ -Bool offsideON = TRUE; /* TRUE => implement offside rule */ +List tyconDefns = NIL; /* type constructor definitions */ +List typeInDefns = NIL; /* type synonym restrictions */ +List valDefns = NIL; /* value definitions in script */ +List classDefns = NIL; /* class defns in script */ +List instDefns = NIL; /* instance defns in script */ +List selDefns = NIL; /* list of selector lists */ +List genDefns = NIL; /* list of generated names */ +List unqualImports = NIL; /* unqualified import list */ +List foreignImports = NIL; /* foreign imports */ +List foreignExports = NIL; /* foreign exportsd */ +List defaultDefns = NIL; /* default definitions (if any) */ +Int defaultLine = 0; /* line in which default defs occur*/ +List evalDefaults = NIL; /* defaults for evaluator */ + +Cell inputExpr = NIL; /* input expression */ +Cell inputContext = NIL; /* input context */ +Bool literateScripts = FALSE; /* TRUE => default to lit scripts */ +Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */ +Bool offsideON = TRUE; /* TRUE => implement offside rule */ +Bool readingInterface = FALSE; String repeatStr = 0; /* Repeat last expr */ @@ -727,7 +728,9 @@ static Text local readIdent() { /* read identifier */ } while (isISO(c0) && isIn(c0,IDAFTER)); endToken(); identType = isIn(tokenStr[0],LARGE) ? CONID : VARID; - return findText(tokenStr); + if (readingInterface) + return unZcodeThenFindText(tokenStr); else + return findText(tokenStr); } @@ -1274,7 +1277,7 @@ static Int indentDepth = (-1); /* current indentation nesting */ static Void local goOffside(col) /* insert offside marker */ Int col; { /* for specified column */ -assert(offsideON); + assert(offsideON); if (indentDepth>=MAXINDENT) { ERRMSG(row) "Too many levels of program nesting" EEND; @@ -1283,12 +1286,12 @@ assert(offsideON); } static Void local unOffside() { /* leave layout rule area */ -assert(offsideON); + assert(offsideON); indentDepth--; } static Bool local canUnOffside() { /* Decide if unoffside permitted */ -assert(offsideON); + assert(offsideON); return indentDepth>=0 && layout[indentDepth]!=HARD; } @@ -1590,9 +1593,11 @@ static Void local parseInput(startWith)/* Parse input with given first tok,*/ Int startWith; { /* determining whether to read a */ firstToken = TRUE; /* script or an expression */ firstTokenIs = startWith; - if (startWith==INTERFACE) - offsideON = FALSE; else - offsideON = TRUE; + if (startWith==INTERFACE) { + offsideON = FALSE; readingInterface = TRUE; + } else { + offsideON = TRUE; readingInterface = FALSE; + } clearStack(); if (yyparse()) { /* This can only be parser overflow */ diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 78dbd3c..2be1e61 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.6 $ - * $Date: 1999/10/29 11:41:04 $ + * $Revision: 1.7 $ + * $Date: 1999/11/29 18:59:28 $ * ------------------------------------------------------------------------*/ /* ToDo: @@ -35,6 +35,7 @@ #include "dynamic.h" #define DEBUG_IFACE +#define VERBOSITY TRUE extern void print ( Cell, Int ); @@ -109,7 +110,7 @@ static Type local conidcellsToTycons Args((Int,Type)); static Void local resolveReferencesInObjectModule Args((Module,Bool)); static Bool local validateOImage Args((void*, Int, Bool)); -static Void local readSyms Args((Module)); +static Void local readSyms Args((Module,Bool)); static void* local lookupObjName ( char* ); @@ -403,7 +404,7 @@ printf ( "new module %s\n", textToStr(t) ); ERRMSG(0) "Read of object file \"%s\" failed", nameObj EEND; } - if (!validateOImage(img,sizeObj,FALSE)) { + if (!validateOImage(img,sizeObj,VERBOSITY)) { ERRMSG(0) "Validation of object file \"%s\" failed", nameObj EEND; } @@ -411,7 +412,7 @@ printf ( "new module %s\n", textToStr(t) ); assert(!module(m).oImage); module(m).oImage = img; - readSyms(m); + readSyms(m,VERBOSITY); if (!cellIsMember(m, ghcModules)) ghcModules = cons(m, ghcModules); @@ -1041,6 +1042,8 @@ List ktyvars; { /* [(VarId|Text,Kind)] */ case QUAL: return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars), tvsToOffsets(line,snd(snd(type)),ktyvars))); + case DICTAP: /* bogus ?? */ + return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars)); case VARIDCELL: /* Ha! some real work to do! */ { Int i = 0; Text tv = textOf(type); @@ -1072,6 +1075,12 @@ 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; Type type; { @@ -1084,7 +1093,7 @@ Type type; { return type; case QUALIDENT: { List t; - Text m = qmodOf(type); + Text m = kludgeGHCPrelText(qmodOf(type)); Text v = qtextOf(type); Module mod = findModule(m); //printf ( "lookup qualident " ); print(type,100); printf("\n"); @@ -1130,6 +1139,8 @@ Type type; { case QUAL: return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))), conidcellsToTycons(line,snd(snd(type))))); + case DICTAP: /* bogus?? */ + return ap(DICTAP, conidcellsToTycons(line, snd(type))); default: fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n", whatIs(type)); @@ -1248,14 +1259,15 @@ static Void local resolveReferencesInObjectModule_elf ( Module m, { char symbol[1000]; // ToDo int i, j; - Elf32_Sym* stab; + Elf32_Sym* stab = NULL; char* strtab; char* ehdrC = (char*)(module(m).oImage); Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC; Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff); Elf32_Word* targ; // first find "the" symbol table - //stab = findElfSection ( objImage, SHT_SYMTAB ); + // why is this commented out??? + stab = findElfSection ( ehdrC, SHT_SYMTAB ); // also go find the string table strtab = findElfSection ( ehdrC, SHT_STRTAB ); @@ -1414,7 +1426,8 @@ static Bool local validateOImage_elf ( void* imgV, if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else if (verb) fprintf ( stderr, " " ); - if (sh_strtab && verb) fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name ); + if (sh_strtab && verb) + fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name ); if (verb) fprintf ( stderr, "\n" ); } @@ -1424,7 +1437,8 @@ static Bool local validateOImage_elf ( void* imgV, for (i = 0; i < ehdr->e_shnum; i++) { if (shdr[i].sh_type == SHT_STRTAB && i != ehdr->e_shstrndx) { - if (verb) fprintf ( stderr, " section %d is a normal string table\n", i ); + if (verb) + fprintf ( stderr, " section %d is a normal string table\n", i ); strtab = ehdrC + shdr[i].sh_offset; nstrtab++; } @@ -1490,7 +1504,7 @@ static Bool local validateOImage_elf ( void* imgV, } -static void readSyms_elf ( Module m ) +static void readSyms_elf ( Module m, Bool verb ) { int i, j, k, nent; Elf32_Sym* stab; @@ -1542,9 +1556,9 @@ static void readSyms_elf ( Module m ) + stab[j].st_value; assert(nm); assert(ad); - /* fprintf(stderr, "addOTabName: %s %s %p\n", - textToStr(module(m).text), nm, ad ); - */ + if (verb) + fprintf(stderr, "addOTabName: %10p %s %s\n", + ad, textToStr(module(m).text), nm ); addOTabName ( m, nm, ad ); } } @@ -1580,10 +1594,10 @@ static Void local resolveReferencesInObjectModule ( Module m, Bool verb ) } -static Void local readSyms ( Module m ) +static Void local readSyms ( Module m, Bool verb ) { #if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) - readSyms_elf ( m ); + readSyms_elf ( m, verb ); #else internal("readSyms: not implemented on this platform"); #endif @@ -1638,7 +1652,7 @@ void* lookupObjName ( char* nm ) pp = strchr(nm2, '_'); if (!pp) goto not_found; *pp = 0; - t = findText(nm2); + t = unZcodeThenFindText(nm2); m = findModule(t); if (isNull(m)) goto not_found; a = lookupOTabName ( m, nm ); diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index df2cdd3..e5ddb05 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.8 $ - * $Date: 1999/11/23 18:08:17 $ + * $Revision: 1.9 $ + * $Date: 1999/11/29 18:59:29 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -174,11 +174,14 @@ List liftBinds( List binds ) for(bs=binds; nonNull(bs); bs=tl(bs)) { StgVar bind = hd(bs); -#if 0 - fprintf(stderr, "\n"); - if (lastModule() != modulePrelude) ppStg(hd(bs)); - fprintf(stderr, "\n"); -#endif + + if (debugSC) { + if (lastModule() != modulePrelude) { + fprintf(stderr, "\n"); + ppStg(hd(bs)); + fprintf(stderr, "\n"); + } + } freeVarsBind(NIL,bind); stgVarInfo(bind) = NONE; /* mark as top level */ } diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c index 03187a5..d20af2c 100644 --- a/ghc/interpreter/output.c +++ b/ghc/interpreter/output.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: output.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/12 17:32:42 $ + * $Revision: 1.13 $ + * $Date: 1999/11/29 18:59:29 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -551,12 +551,13 @@ Cell e; { /* args not yet printed ... */ return ts; } -Void unlexVar(t) /* print text as a variable name */ -Text t; { /* operator symbols must be enclosed*/ - String s = textToStr(t); /* in parentheses... except [] ... */ - +Void unlexVarStr(s) +String s; { if ((isascii((int)(s[0])) && isalpha((int)(s[0]))) - || s[0]=='_' || s[0]=='[' || s[0]=='(') + || s[0]=='_' || s[0]=='[' || s[0]=='(' + || s[0]=='$' + || (s[0]==':' && s[1]=='D') + ) putStr(s); else { putChr('('); @@ -565,6 +566,11 @@ Text t; { /* operator symbols must be enclosed*/ } } +Void unlexVar(t) /* print text as a variable name */ +Text t; { /* operator symbols must be enclosed*/ + unlexVarStr(textToStr(t)); /* in parentheses... except [] ... */ +} + static Void local unlexOp(t) /* print text as operator name */ Text t; { /* alpha numeric symbols must be */ String s = textToStr(t); /* enclosed by backquotes */ diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index a54ff1e..282650d 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.17 $ - * $Date: 1999/11/17 16:57:44 $ + * $Revision: 1.18 $ + * $Date: 1999/11/29 18:59:30 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1389,10 +1389,8 @@ Class c; { * Self-improvement (of a C with a C, or a D with a D) is treated as a * special case of an inherited dependency. * ------------------------------------------------------------------------*/ -static List local inheritFundeps(c,pi,o) -Class c; -Cell pi; -Int o; { +static List local inheritFundeps ( Class c, Cell pi, Int o ) +{ Int alpha = newKindedVars(cclass(c).kinds); List scs = cclass(c).supers; List xfds = NIL; @@ -1422,8 +1420,8 @@ Int o; { return xfds; } -static Void local extendFundeps(c) -Class c; { +static Void local extendFundeps ( Class c ) +{ Int alpha; emptySubstitution(); alpha = newKindedVars(cclass(c).kinds); @@ -1593,8 +1591,13 @@ Class c; { /* and other parts of class struct.*/ */ mno = cclass(c).numSupers + cclass(c).numMembers; - cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); - implementCfun(cclass(c).dcon,NIL); /* ADR addition */ + /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */ + cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL); + /* implementCfun(cclass(c).dcon,NIL); + Don't manufacture a wrapper fn for dictionary constructors. + Applications of dictionary constructors are always saturated, + and translate.c:stgExpr() special-cases saturated constructor apps. + */ if (mno==1) { /* Single entry dicts use newtype */ name(cclass(c).dcon).defn = nameId; @@ -1634,7 +1637,8 @@ Int no; { Name s; char buf[16]; - sprintf(buf,"sc%d.%s",no,"%s"); + /* sprintf(buf,"sc%d.%s",no,"%s"); */ + sprintf(buf,"$p%d%s",no+1,"%s"); s = newName(generateText(buf,c),c); name(s).line = cclass(c).line; name(s).arity = 1; @@ -3246,7 +3250,8 @@ static Void local checkDefaultDefns() { /* check that default types are */ * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism. * They are used to "import" C functions into a module. * They are usually not written by hand but, rather, generated automatically - * by GreenCard, IDL compilers or whatever. + * by GreenCard, IDL compilers or whatever. We support foreign import + * (static) and foreign import dynamic. In the latter case, extName==NIL. * * Foreign export declarations generate C wrappers for Hugs functions. * Hugs only provides "foreign export dynamic" because it's not obvious diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index 742fe27..f426799 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stg.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/11/12 17:32:45 $ + * $Revision: 1.9 $ + * $Date: 1999/11/29 18:59:32 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -449,7 +449,7 @@ Void putStgExpr( StgExpr e ) /* pretty print expr */ case STGPRIM: { Cell op = stgPrimOp(e); - unlexVar(name(op).text); + unlexVarStr(asmGetPrimopName(name(op).primop)); putStgAtoms(stgPrimArgs(e)); break; } diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 8dd64a2..93c4dd4 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.18 $ - * $Date: 1999/11/25 12:12:25 $ + * $Revision: 1.19 $ + * $Date: 1999/11/29 18:59:32 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -230,6 +230,166 @@ Text t; { /* at top of text table */ } +static int fromHexDigit ( char c ) +{ + switch (c) { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + return c - '0'; + case 'a': case 'A': return 10; + case 'b': case 'B': return 11; + case 'c': case 'C': return 12; + case 'd': case 'D': return 13; + case 'e': case 'E': return 14; + case 'f': case 'F': return 15; + default: return -1; + } +} + + +/* returns findText (unZencode s) */ +Text unZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn, i; + Text t; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("unZcodeThenFindText: malloc failed"); + n = 0; + + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("unZcodeThenFindText: result is too big"); + if (*s != 'z' && *s != 'Z') { + p[n] = *s; n++; s++; + continue; + } + s++; + if (!(*s)) goto parse_error; + switch (*s++) { + case 'Z': p[n++] = 'Z'; break; + case 'C': p[n++] = ':'; break; + case 'L': p[n++] = '('; break; + case 'R': p[n++] = ')'; break; + case 'M': p[n++] = '['; break; + case 'N': p[n++] = ']'; break; + case 'z': p[n++] = 'z'; break; + case 'a': p[n++] = '&'; break; + case 'b': p[n++] = '|'; break; + case 'd': p[n++] = '$'; break; + case 'e': p[n++] = '='; break; + case 'g': p[n++] = '>'; break; + case 'h': p[n++] = '#'; break; + case 'i': p[n++] = '.'; break; + case 'l': p[n++] = '<'; break; + case 'm': p[n++] = '-'; break; + case 'n': p[n++] = '!'; break; + case 'p': p[n++] = '+'; break; + case 'q': p[n++] = '\\'; break; + case 'r': p[n++] = '\''; break; + case 's': p[n++] = '/'; break; + case 't': p[n++] = '*'; break; + case 'u': p[n++] = '^'; break; + case 'v': p[n++] = '%'; break; + case 'x': + if (!s[0] || !s[1]) goto parse_error; + if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error; + p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]); + p += 2; s += 2; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = 0; + s--; + while (*s && isdigit((int)(*s))) { + i = 10 * i + (*s - '0'); + s++; + } + if (*s != 'T') goto parse_error; + s++; + p[n++] = '('; + while (i > 0) { p[n++] = ','; i--; }; + p[n++] = ')'; + break; + default: + goto parse_error; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; + + parse_error: + free(p); + fprintf ( stderr, "\nstring = `%s'\n", s ); + internal ( "unZcodeThenFindText: parse error on above string"); + return NIL; /*notreached*/ +} + + +Text enZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn; + Text t; + char toHex[16] = "0123456789ABCDEF"; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("enZcodeThenFindText: malloc failed"); + n = 0; + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("enZcodeThenFindText: result is too big"); + if (*s != 'z' + && *s != 'Z' + && (isalnum((int)(*s)) || *s == '_')) { + p[n] = *s; n++; s++; + continue; + } + switch (*s++) { + case '(': p[n++] = 'Z'; p[n++] = 'L'; break; + case ')': p[n++] = 'Z'; p[n++] = 'R'; break; + case '[': p[n++] = 'Z'; p[n++] = 'M'; break; + case ']': p[n++] = 'Z'; p[n++] = 'N'; break; + case ':': p[n++] = 'Z'; p[n++] = 'C'; break; + case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break; + case 'z': p[n++] = 'z'; p[n++] = 'z'; break; + case '&': p[n++] = 'z'; p[n++] = 'a'; break; + case '|': p[n++] = 'z'; p[n++] = 'b'; break; + case '$': p[n++] = 'z'; p[n++] = 'd'; break; + case '=': p[n++] = 'z'; p[n++] = 'e'; break; + case '>': p[n++] = 'z'; p[n++] = 'g'; break; + case '#': p[n++] = 'z'; p[n++] = 'h'; break; + case '.': p[n++] = 'z'; p[n++] = 'i'; break; + case '<': p[n++] = 'z'; p[n++] = 'l'; break; + case '-': p[n++] = 'z'; p[n++] = 'm'; break; + case '!': p[n++] = 'z'; p[n++] = 'n'; break; + case '+': p[n++] = 'z'; p[n++] = 'p'; break; + case '\'': p[n++] = 'z'; p[n++] = 'q'; break; + case '\\': p[n++] = 'z'; p[n++] = 'r'; break; + case '/': p[n++] = 'z'; p[n++] = 's'; break; + case '*': p[n++] = 'z'; p[n++] = 't'; break; + case '^': p[n++] = 'z'; p[n++] = 'u'; break; + case '%': p[n++] = 'z'; p[n++] = 'v'; break; + default: s--; p[n++] = 'z'; p[n++] = 'x'; + p[n++] = toHex[(int)(*s)/16]; + p[n++] = toHex[(int)(*s)%16]; + s++; break; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; +} + + /* -------------------------------------------------------------------------- * Ext storage: * @@ -319,7 +479,7 @@ Tycon tc; { static Void local hashTycon(tc) /* Insert Tycon into hash table */ Tycon tc; { - assert(isTycon(tc)); + assert(isTycon(tc)); if (1) { Text t = tycon(tc).text; Int h = tHash(t); @@ -399,6 +559,20 @@ List ts; { /* Null pattern matches every tycon*/ return ts; } +Text ghcTupleText(tup) +Tycon tup; { + Int i; + char buf[103]; + assert(isTuple(tup)); + tup = tupleOf(tup); + if (tup >= 100) internal("ghcTupleText"); + buf[0] = '('; + for (i = 1; i <= tup; i++) buf[i] = ','; + buf[i] = ')'; + buf[i+1] = 0; + return findText(buf); +} + /* -------------------------------------------------------------------------- * Name storage: * @@ -1064,9 +1238,14 @@ void addDLSect ( Module m, void* start, void* end, DLSect sect ) void* lookupOTabName ( Module m, char* nm ) { int i; - for (i = 0; i < module(m).usedoTab; i++) + for (i = 0; i < module(m).usedoTab; i++) { + if (0) + fprintf ( stderr, + "lookupOTabName: request %s, table has %s\n", + nm, module(m).oTab[i].nm ); if (0==strcmp(nm,module(m).oTab[i].nm)) return module(m).oTab[i].ad; + } return NULL; } diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 33829fa..568c25c 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.13 $ - * $Date: 1999/11/17 16:57:48 $ + * $Revision: 1.14 $ + * $Date: 1999/11/29 18:59:34 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -53,11 +53,13 @@ typedef Cell Ext; /* extension label */ * names, string literals, character constants etc... * ------------------------------------------------------------------------*/ -extern String textToStr Args((Text)); -extern Text findText Args((String)); -extern Text inventText Args((Void)); -extern Text inventDictText Args((Void)); -extern Bool inventedText Args((Text)); +extern String textToStr Args((Text)); +extern Text findText Args((String)); +extern Text inventText Args((Void)); +extern Text inventDictText Args((Void)); +extern Bool inventedText Args((Text)); +extern Text enZcodeThenFindText Args((String)); +extern Text unZcodeThenFindText Args((String)); /* Variants of textToStr and syntaxOf which work for idents, ops whether * qualified or unqualified. @@ -380,6 +382,9 @@ extern Ptr cptrOf Args((Cell)); #endif #define mkTuple(n) (TUPMIN+(n)) #define tupleOf(n) ((Int)((n)-TUPMIN)) +extern Text ghcTupleText Args((Tycon)); + + #if TREX #define EXTMIN (TUPMIN+NUM_TUPLES) @@ -552,7 +557,7 @@ struct strName { Cell defn; Cell stgVar; /* really StgVar */ Text callconv; /* for foreign import/export */ - const void* primop; /* really StgPrim* */ + void* primop; /* really StgPrim* */ Name nextNameHash; }; diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index cd4529f..9c625e9 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.16 $ - * $Date: 1999/11/23 15:12:06 $ + * $Revision: 1.17 $ + * $Date: 1999/11/29 18:59:34 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1755,9 +1755,11 @@ Class c; { /* defaults for class c */ } for (; nonNull(mems); mems=tl(mems)) { - static String deftext = "default_"; + /* static String deftext = "default_"; */ + static String deftext = "$dm"; String s = textToStr(name(hd(mems)).text); Name n; + i = j = 0; for (; isp; } -void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base ) +void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base ) { emiti_8(bco,prim->prefix,prim->opcode); setSp(bco, base); } +char* asmGetPrimopName ( AsmPrim* p ) +{ + return p->name; +} + /* Hugs used to let you add arbitrary primops with arbitrary types * just by editing Prelude.hs or any other file you wanted. * We deliberately avoided that approach because we wanted more * control over which primops are provided. */ -const AsmPrim asmPrimOps[] = { +AsmPrim asmPrimOps[] = { /* Char# operations */ { "primGtChar", "CC", "B", MONAD_Id, i_PRIMOP1, i_gtChar } @@ -1425,17 +1430,17 @@ const AsmPrim asmPrimOps[] = { , { 0,0,0,0,0,0 } }; -const AsmPrim ccall_ccall_Id +AsmPrim ccall_ccall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_Id }; -const AsmPrim ccall_ccall_IO +AsmPrim ccall_ccall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_ccall_IO }; -const AsmPrim ccall_stdcall_Id +AsmPrim ccall_stdcall_Id = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_Id }; -const AsmPrim ccall_stdcall_IO +AsmPrim ccall_stdcall_IO = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO }; -const AsmPrim* asmFindPrim( char* s ) +AsmPrim* asmFindPrim( char* s ) { int i; for (i=0; asmPrimOps[i].name; ++i) { @@ -1446,7 +1451,7 @@ const AsmPrim* asmFindPrim( char* s ) return 0; } -const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) +AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op ) { nat i; for (i=0; asmPrimOps[i].name; ++i) { diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 1ef92e1..681cb6b 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Evaluator.c,v $ - * $Revision: 1.29 $ - * $Date: 1999/11/18 16:02:18 $ + * $Revision: 1.30 $ + * $Date: 1999/11/29 18:59:42 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -3059,9 +3059,12 @@ off the stack. case i_ccall_stdcall_IO: { int r; - CFunDescriptor* descriptor = PopTaggedAddr(); - void (*funPtr)(void) = PopTaggedAddr(); - char cc = (primop2code == i_ccall_stdcall_Id || + CFunDescriptor* descriptor; + void (*funPtr)(void); + char cc; + descriptor = PopTaggedAddr(); + funPtr = PopTaggedAddr(); + cc = (primop2code == i_ccall_stdcall_Id || primop2code == i_ccall_stdcall_IO) ? 's' : 'c'; r = ccall(descriptor,funPtr,bco,cc,cap); diff --git a/ghc/rts/Printer.c b/ghc/rts/Printer.c index 844acca..cbb20dd 100644 --- a/ghc/rts/Printer.c +++ b/ghc/rts/Printer.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Printer.c,v 1.17 1999/11/22 16:44:33 sewardj Exp $ + * $Id: Printer.c,v 1.18 1999/11/29 18:59:46 sewardj Exp $ * * Copyright (c) 1994-1999. * @@ -312,10 +312,12 @@ StgPtr printStackObj( StgPtr sp ) if (IS_ARG_TAG(*sp)) { nat i; StgWord tag = *sp++; - fprintf(stderr,"Tag: %d words\n", tag); + fprintf(stderr,"Tagged{"); for (i = 0; i < tag; i++) { - fprintf(stderr,"Word# %d\n", *sp++); + fprintf(stderr,"0x%x#", (unsigned)(*sp++)); + if (i < tag-1) fprintf(stderr, ", "); } + fprintf(stderr, "}\n"); } else { StgClosure* c = (StgClosure*)(*sp); printPtr((StgPtr)*sp); -- 1.7.10.4