/* -----------------------------------------------------------------------------
- * $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.
*
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 );
* 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;
* 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 $
* ------------------------------------------------------------------------*/
/* 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
* 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"
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
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;
}
} 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;
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#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 */
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 */
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]) */
* 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 <setjmp.h>
#include "Rts.h"
#include "RtsAPI.h"
#include "Schedule.h"
-
+#include "Assembler.h" /* DEBUG_LoadSymbols */
Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
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 {
#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},
);
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;
}
/* 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);
* 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"
* 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 */
} 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);
}
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;
}
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;
}
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 */
* 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:
#include "dynamic.h"
#define DEBUG_IFACE
+#define VERBOSITY TRUE
extern void print ( Cell, Int );
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* );
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;
}
assert(!module(m).oImage);
module(m).oImage = img;
- readSyms(m);
+ readSyms(m,VERBOSITY);
if (!cellIsMember(m, ghcModules))
ghcModules = cons(m, ghcModules);
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);
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; {
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");
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));
{
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 );
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" );
}
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++;
}
}
-static void readSyms_elf ( Module m )
+static void readSyms_elf ( Module m, Bool verb )
{
int i, j, k, nent;
Elf32_Sym* stab;
+ 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 );
}
}
}
-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
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 );
* 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"
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 */
}
* 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"
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('(');
}
}
+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 */
* 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"
* 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;
return xfds;
}
-static Void local extendFundeps(c)
-Class c; {
+static Void local extendFundeps ( Class c )
+{
Int alpha;
emptySubstitution();
alpha = newKindedVars(cclass(c).kinds);
*/
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;
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;
* 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
* 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"
case STGPRIM:
{
Cell op = stgPrimOp(e);
- unlexVar(name(op).text);
+ unlexVarStr(asmGetPrimopName(name(op).primop));
putStgAtoms(stgPrimArgs(e));
break;
}
* 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"
}
+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:
*
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);
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:
*
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;
}
* 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 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* 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.
#endif
#define mkTuple(n) (TUPMIN+(n))
#define tupleOf(n) ((Int)((n)-TUPMIN))
+extern Text ghcTupleText Args((Tycon));
+
+
#if TREX
#define EXTMIN (TUPMIN+NUM_TUPLES)
Cell defn;
Cell stgVar; /* really StgVar */
Text callconv; /* for foreign import/export */
- const void* primop; /* really StgPrim* */
+ void* primop; /* really StgPrim* */
Name nextNameHash;
};
* 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"
}
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 (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
buf[i] = deftext[i];
}
locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
name(inst(in).builder).defn /* Register builder imp */
- = singleton(pair(args,ap(LETREC,pair(singleton(locs),
- ap(l,d)))));
+ = singleton(pair(args,ap(LETREC,pair(singleton(locs),
+ ap(l,d)))));
+
+ /* Invent a GHC-compatible name for the instance decl */
+ {
+ char buf[FILENAME_MAX+1];
+ Int i, j;
+ String str;
+ Cell qq = inst(in).head;
+ Cell pp = NIL;
+ static String zdftext = "$f";
+
+ while (isAp(qq)) {
+ pp = cons(arg(qq),pp);
+ qq = fun(qq);
+ }
+ // pp is now the fwd list of args(?) to this pred
+
+ i = 0;
+ for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
+ buf[i] = zdftext[j];
+ }
+ str = textToStr(cclass(inst(in).c).text);
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ for (; nonNull(pp); pp=tl(pp)) {
+ qq = hd(pp);
+ while (isAp(qq)) qq = fun(qq);
+ switch (whatIs(qq)) {
+ case TYCON: str = textToStr(tycon(qq).text); break;
+ case TUPLE: str = textToStr(ghcTupleText(qq)); break;
+ default: internal("typeInstDefn: making GHC name"); break;
+ }
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ }
+
+ buf[i++] = '\0';
+ name(inst(in).builder).text = findText(buf);
+ //fprintf ( stderr, "result = %s\n", buf );
+ }
+
genDefns = cons(inst(in).builder,genDefns);
}
#if MAJOR_RELEASE
#define HUGS_VERSION "November 1999 "
#else
-#define HUGS_VERSION "STGHugs-991125"
+#define HUGS_VERSION "STGHugs-991129"
#endif
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.18 $
- * $Date: 1999/11/19 15:42:12 $
+ * $Revision: 1.19 $
+ * $Date: 1999/11/29 18:59:40 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
return bco->sp;
}
-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 }
, { 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) {
return 0;
}
-const AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
+AsmPrim* asmFindPrimop( AsmInstr prefix, AsmInstr op )
{
nat i;
for (i=0; asmPrimOps[i].name; ++i) {
* 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"
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);
/* -----------------------------------------------------------------------------
- * $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.
*
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);
projects / ghc-hetmet.git / commitdiff