/* get the pointer to an Expression Application's function. This just
* involves using readFO to pull out the correct pointer.
*/
FileOffset
getFuncPtr( FileOffset fo )
{
char *id, c;
FileOffset ptr = 0;
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
//fprintf(stderr, "considering 1st expression at %x\n", fo);
switch (lower5(c)) {
case ExpApp:
if (hasSrcPos(c)) { readFO(); }
readFO(); /* skip parent */
readFO(); /* skip result */
fo = readFO(); /* value app */
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
//fprintf(stderr, "considering 2nd expression at %x\n", fo);
readFO(); /* skip srcref */
readFO(); /* skip parent */
ptr = readFO(); /* function ptr */
break;
default:
fprintf(stderr, "%s: expected Expression Application at 0x%x\n",
progname,fo);
exit(1);
}
//fprintf(stderr, "pointer: %x\n", ptr);
return ptr;
}
/**
* Attempt to read a value applicaiton expression type node at a certain offset.
*
* @param hatFile The file to read the node from.
* @param offset The offset where the start of the node should be.
* @return A node construct containing the read values.
*/
node* readExpValueApp(FILE *hatFile, unsigned long offset)
{
int argIndex;
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpValueApp;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expValueApp.hasUse = hasSrcPos(tag))
{
newNode->params.expValueApp.use = readPointer(hatFile);
}
newNode->params.expValueApp.parent = readPointer(hatFile);
newNode->params.expValueApp.function = readPointer(hatFile);
newNode->params.expValueApp.arity = readArity(hatFile);
newNode->params.expValueApp.args = (unsigned long *)malloc(newNode->params.expValueApp.arity * sizeof(unsigned long));
for (argIndex = 0; argIndex < newNode->params.expValueApp.arity; argIndex++)
{
newNode->params.expValueApp.args[argIndex] = readPointer(hatFile);
}
return newNode;
}
node* readExpFieldUpdate(FILE *hatFile, unsigned long offset)
{
int argIndex;
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpFieldUpdate;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expFieldUpdate.hasUse = hasSrcPos(tag))
{
newNode->params.expFieldUpdate.use = readPointer(hatFile);
}
newNode->params.expFieldUpdate.parent = readPointer(hatFile);
newNode->params.expFieldUpdate.result = readPointer(hatFile);
newNode->params.expFieldUpdate.arg = readPointer(hatFile);
newNode->params.expFieldUpdate.arity = readArity(hatFile);
newNode->params.expFieldUpdate.bindees = (unsigned long *)malloc(newNode->params.expFieldUpdate.arity * sizeof(unsigned long));
newNode->params.expFieldUpdate.binders = (unsigned long *)malloc(newNode->params.expFieldUpdate.arity * sizeof(unsigned long));
for (argIndex = 0; argIndex < newNode->params.expFieldUpdate.arity; argIndex++)
{
newNode->params.expFieldUpdate.binders[argIndex] = readPointer(hatFile);
}
for (argIndex = 0; argIndex < newNode->params.expFieldUpdate.arity; argIndex++)
{
newNode->params.expFieldUpdate.bindees[argIndex] = readPointer(hatFile);
}
return newNode;
}
node* readExpDoStmt(FILE *hatFile, unsigned long offset)
{
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpDoStmt;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expDoStmt.hasUse = hasSrcPos(tag))
{
newNode->params.expDoStmt.use = readPointer(hatFile);
}
newNode->params.expDoStmt.statement = readPointer(hatFile);
return newNode;
}
/* This function is used by getImmediateExpArg, to follow argument
* pointers. It follows ExpConstUse pointers, but nothing else.
* Otherwise, it simply returns the pointer value.
* I could probably fold this into the getImmediateExpArg function body.
*/
getResultRestricted(FileOffset fo)
{
char c;
FileOffset ptr;
if (fo<=DoLambda) return fixInterrupt(fo);
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* CAF */
return getResultRestricted(ptr);
break;
default:
return fo;
break;
}
}
node* readExpInteger(FILE *hatFile, unsigned long offset)
{
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpInteger;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expInteger.hasUse = hasSrcPos(tag))
{
newNode->params.expInteger.use = readPointer(hatFile);
}
newNode->params.expInteger.parent = readPointer(hatFile);
newNode->params.expInteger.value = readString(hatFile);
return newNode;
}
/**
* Attempt to read a value use expression type node at a certain offset.
*
* @param hatFile The file to read the node from.
* @param offset The offset where the start of the node should be.
* @return A node construct containing the read values.
*/
node* readExpValueUse(FILE *hatFile, unsigned long offset)
{
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpValueUse;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expValueUse.hasUse = hasSrcPos(tag))
{
newNode->params.expValueUse.use = readPointer(hatFile);
}
newNode->params.expValueUse.parent = readPointer(hatFile);
newNode->params.expValueUse.value = readPointer(hatFile);
newNode->params.expValueUse.isLambda = (newNode->params.expValueUse.value == 4);
return newNode;
}
node* readExpRational(FILE *hatFile, unsigned long offset)
{
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpRational;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expRational.hasUse = hasSrcPos(tag))
{
newNode->params.expRational.use = readPointer(hatFile);
}
newNode->params.expRational.parent = readPointer(hatFile);
newNode->params.expRational.numerator = readString(hatFile);
newNode->params.expRational.denominator = readString(hatFile);
return newNode;
}
node* readExpIf(FILE *hatFile, unsigned long offset)
{
node *newNode = (node *)malloc(sizeof(node));
char tag;
newNode->nodeType = ExpIf;
newNode->offset = offset;
setFilePos(hatFile, offset);
tag = readByte(hatFile);
if (newNode->params.expIf.hasUse = hasSrcPos(tag))
{
newNode->params.expIf.use = readPointer(hatFile);
}
newNode->params.expIf.parent = readPointer(hatFile);
newNode->params.expIf.result = readPointer(hatFile);
newNode->params.expIf.condition = readPointer(hatFile);
return newNode;
}
/* mark all the nodes in the hat file that are reachable
* from the given root -- setting the highest bit in the
* tag byte
*/
void
markfrom (FileOffset root, FileOffset *buf)
{
char tag;
if (root > 8 && root < filesize) {
/* First read the tag byte. If it is marked, return.
* If it is not marked, then mark it now.
*/
fseek(f,(long int)root,SEEK_SET);
fread(&tag,sizeof(char),1,f);
if (ismarked(tag)) return;
marktag(&tag);
fseek(f,(long int)root,SEEK_SET);
fwrite(&tag,sizeof(char),1,f);
cleartag(&tag);
/* Examine the tag to determine the kind of node.
* Read pointers from the node into buf, then
* markfrom() these pointers recursively. The buffer is
* overwritten where possible to minimise the risk of overflow:
* for this reason, pointers are recursively traced in
* reverse order.
*/
{
int k = lo5(tag);
if ((ExpDoStmt < k && k < AtomVariable) || k > ListCons) {
fprintf(stderr, "strange tag %d at 0x%x\n",
k, root);
exit(1);
}
switch (k) {
case ListCons:
fread(buf,sizeof(FileOffset),2,f); /* two pointers */
markfrom(getpointer(buf+1),buf+1);
markfrom(getpointer(buf),buf);
break;
case Module: break;
case AtomAbstract: break;
case SrcPos:
case AtomVariable:
case AtomConstructor: /* ignore fieldnames for now */
fread(buf,sizeof(FileOffset),1,f); /* points to module mode */
markfrom(getpointer(buf),buf);
break;
default: {
int pos = 0;
if (hasSrcPos(tag)) {
fread(buf+pos,sizeof(FileOffset),1,f);
pos++;
}
fread(buf+pos,sizeof(FileOffset),1,f); /* parent pointer */
pos++;
switch (k) {
case ExpApp:
fread(buf+pos,sizeof(FileOffset),2,f); /* result+fun */
pos += 2;
{ unsigned char arity;
fread(&arity,sizeof(unsigned char),1,f);
fread(buf+pos,sizeof(FileOffset),(unsigned int)arity,f);
pos += (int)arity;
}
break;
case ExpValueApp:
fread(buf+pos,sizeof(FileOffset),1,f); /* fun */
pos += 1;
{ unsigned char arity;
fread(&arity,sizeof(unsigned char),1,f);
fread(buf+pos,sizeof(FileOffset),(unsigned int)arity,f);
pos += (int)arity;
}
break;
case ExpValueUse:
case ExpConstUse:
case ExpProjection:
fread(buf+pos,sizeof(FileOffset),1,f); /* one extra pointer */
pos++;
break;
case ExpHidden:
case ExpConstDef:
case ExpFieldUpdate: /* ignore fieldnames for now */
case ExpGuard:
case ExpCase:
case ExpIf:
fread(buf+pos,sizeof(FileOffset),2,f); /* two pointers */
pos+=2;
break;
default: break; /* no pointers */
}
for (;pos-->0;) markfrom(getpointer(buf+pos), buf+pos);
} break;
}
}
}
}
void
nextnode (void)
{
FileOffset offset = nextoffset;
char b;
int marked, err;
err = fread(&b,sizeof(char),1,f); nextoffset+=1;
if (err!=1) return;
if (rmode || xmode) {
marked = ismarked(b);
if (marked) {
cleartag(&b);
newtagat(&b, offset);
}
if (amode) printf("%s", (marked ? "=> " : " "));
}
{
int k = lo5(b);
if ((ExpDoStmt<k && k<AtomVariable) || k>ListCons) {
fprintf(stderr, "strange tag %d at byte offset 0x%x\n",
k, offset);
exit(1);
} else if (smode) {
count[k]++;
if (rmode && marked) reachcount[k]++;
}
switch (k) {
case ListCons:
if (gmode) printf("%d [label=\"0x%x ListCons\"]\n", offset, offset);
if (amode) printf("0x%x: %-20s\t", offset, tag2str(k));
if (amode) printf("elem=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "e");
if (amode) printf(" tail=");
dopointer(MAYBEZERO, ListCons, readpointer(), k, offset, "t");
break;
case Module:
if (amode) {
if (tracedModule(b))
printf("0x%x: Module (suspect) \t", offset);
else printf("0x%x: Module (trusted) \t", offset);
}
{ char *s = readstring(); if (amode) printf("%s\t", s); }
{ char *s = readstring(); if (amode) printf("\"%s\"", s); }
break;
case SrcPos:
if (amode) printf("0x%x: SrcPos\t\t\t", offset);
dopointer(NONZERO, Module, readpointer(), k, offset, "");
{ char *p = readposn(); if (amode) printf(" %s", p); }
break;
case AtomVariable:
if (amode) {
if (localDef(b))
printf("0x%x: AtomVariable (local)\t", offset);
else printf("0x%x: AtomVariable (toplevel)\t", offset);
}
if (gmode) printf("%d [label=\"0x%x AtomVariable", offset, offset);
dopointer(NONZERO, Module, readpointer(), k, offset, "");
{ char *p = readposn(); if (amode) printf(" %s", p); }
{ char *fp = readfixpri(); if (*fp!='\0' && amode) printf("%s ", fp); }
{ unsigned int a = readarity();
if (amode || gmode) printf(amode ? " arity=%u," : " %u", a); }
{ char *n = readstring(); if (amode || gmode) printf(" %s", n); }
if (gmode) printf("\"]\n");
break;
case AtomConstructor:
if (amode) printf("0x%x: %-20s\t", offset, tag2str(k));
if (gmode) printf("%d [label=\"0x%x AtomConstructor", offset, offset);
dopointer(NONZERO, Module, readpointer(), k, offset, "");
{ char *p = readposn(); if (amode) printf(" %s", p); }
{ char *fp = readfixpri(); if (*fp!='\0' && amode) printf("%s", fp); }
{ unsigned int a = readarity();
if (amode || gmode) printf(amode ? " arity=%u," : " %u", a);
{ char *n = readstring(); if (amode || gmode) printf(" %s", n); }
if (gmode) printf("\"]\n");
if hasFields(b) {
int i;
if (amode) printf(" fields:");
for (i=1; i<=a; i++) {
dopointer(NONZERO, AtomVariable, readpointer(), k, offset,
(gmode ? (sprintf(stringbuf,"%d",i), stringbuf) : "")
);
}
}
}
break;
case AtomAbstract:
if (amode) printf("0x%x: %-20s\t", offset, tag2str(k));
if (gmode) printf("%d [label=\"0x%x AtomAbstract ", offset, offset);
{ char *s = readstring(); if (amode || gmode) printf("%s", s); }
if (gmode) printf("\"]\n");
break;
default: {
if (amode) printf("0x%x: %-20s\t", offset, tag2str(k));
if (hasSrcPos(b)) {
if (amode) printf("use=");
dopointer(NONZERO, SrcPos, readpointer(), k, offset, "");
if (amode) printf(" ");
}
// if (amode && (ExpChar <= k) && (k <= ExpConstUse)) {
// printf("(");
// if (!isEntered(b)) printf("not ");
// printf("entered) ");
// }
switch (k) {
case ExpApp:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" result=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "r");
if (amode) printf(" fun=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "f");
if (gmode) printf("%d [label=\"0x%x ExpApp", offset, offset);
{ unsigned int a = readarity();
int i;
if (amode || gmode)
printf(amode ? " arity=%u, args " : " %u\"]\n",a);
for (i=1; i<=a; i++)
dopointer(NONZERO, ANYEXP, readpointer(), k, offset,
(gmode ? (sprintf(stringbuf,"%d",i), stringbuf) : "")
);
}
break;
case ExpValueApp:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" fun=");
dopointer(NONZERO, ANYATOM, readpointer(), k, offset, "f");
if (gmode) printf("%d [label=\"0x%x ExpValueApp", offset, offset);
{ unsigned int a = readarity();
int i;
if (amode || gmode)
printf(amode ? " arity=%u, args " : " %u\"]\n",a);
for (i=1; i<=a; i++)
dopointer(NONZERO, ANYEXP, readpointer(), k, offset,
(gmode ? (sprintf(stringbuf,"%d",i), stringbuf) : "")
);
}
break;
case ExpChar:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ char c = nextbyte();
if (gmode) printf("%d [label=\"ExpChar", offset);
if (amode || gmode) printf(" '%c'", c);
if (gmode) printf("\"]\n");
}
break;
case ExpInt:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ int i; i = readfourbytes();
if (gmode) printf("%d [label=\"ExpInt", offset);
if (amode || gmode) printf(" %d", i);
if (gmode) printf("\"]\n");
}
break;
case ExpInteger:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ char* i; i = readinteger();
if (gmode) printf("%d [label=\"ExpInteger", offset);
if (amode || gmode) printf(" %s", i);
if (gmode) printf("\"]\n");
}
break;
case ExpRat:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ int n,d; n=readfourbytes(); d=readfourbytes();
if (gmode) printf("%d [label=\"ExpRat", offset);
if (amode || gmode) printf(" %d%%%d", n,d);
if (gmode) printf("\"]\n");
}
break;
case ExpRational:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ char* r = readrational();
if (gmode) printf("%d [label=\"ExpRational", offset);
if (amode || gmode) printf(" %s", r);
if (gmode) printf("\"]\n");
}
break;
case ExpFloat:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ float f = readfloat();
if (gmode) printf("%d [label=\"ExpFloat", offset);
if (amode || gmode) printf(" %f", f);
if (gmode) printf("\"]\n");
}
break;
case ExpDouble:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
{ double d = readdouble();
if (gmode) printf("%d [label=\"ExpDouble", offset);
if (amode || gmode) printf(" %f", d);
if (gmode) printf("\"]\n");
}
break;
case ExpValueUse:
if (gmode) printf("%d [label=\"0x%x ExpValueUse\"]\n", offset, offset);
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" value=");
dopointer(MAYBELAMBDA, ANYATOM, readpointer(), ExpValueUse, offset,"v");
break;
case ExpConstUse:
if (gmode) printf("%d [label=\"0x%x ExpConstUse\"]\n", offset, offset);
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" const=");
dopointer(NONZERO, ExpConstDef, readpointer(), k, offset, "c");
break;
case ExpConstDef:
if (gmode) printf("%d [label=\"0x%x ExpConstDef\"]\n", offset, offset);
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" result=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "r");
if (amode) printf(" var=");
dopointer(NONZERO, AtomVariable, readpointer(), k, offset, "v");
break;
case ExpGuard:
case ExpCase:
case ExpIf:
if (gmode) printf("%d [label=\"0x%x %s\"]\n", offset, offset,
k==ExpGuard ? "ExpGuard" : k==ExpCase ? "ExpCase" : "ExpIf");
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" result=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "r");
if (amode) printf(" cond=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "c");
break;
case ExpFieldUpdate:
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" result=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "r");
if (amode) printf(" arg=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "a");
{ unsigned int i, arity = readarity();
if (gmode) printf("%d [label=\"0x%x ExpFieldUpdate %u\"]\n", offset, offset, arity);
if (amode) printf(" arity=%u, binders ",arity);
for (i=0; i<arity; i++) {
dopointer(NONZERO, AtomVariable, readpointer(), k, offset, "");
}
if (amode) printf(", bindees ",arity);
for (i=0; i<arity; i++) {
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "");
}
}
break;
case ExpProjection:
if (gmode) printf("%d [label=\"0x%x ExpProjection\"]\n", offset, offset);
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" exp=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "e");
break;
case ExpHidden:
if (gmode) printf("%d [label=\"0x%x ExpHidden\"]\n", offset, offset);
if (amode) printf("parent=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "p");
if (amode) printf(" result=");
dopointer(MAYBEZERO, ANYEXP, readpointer(), k, offset, "r");
if (amode) printf(" children=");
dopointer(MAYBEZERO, ListCons, readpointer(), k, offset, "c");
break;
case ExpForward:
if (gmode) printf("%d [label=\"0x%x ExpForward\"]\n", offset, offset);
if (amode) printf("result=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "r");
break;
case ExpDoStmt:
if (gmode) printf("%d [label=\"0x%x ExpDoStmt\"]\n", offset, offset);
if (amode) printf("stmt=");
dopointer(NONZERO, ANYEXP, readpointer(), k, offset, "s");
break;
}
}}
if (amode) printf("\n");
if (smode) space[k] += nextoffset - offset;
}
}
/* Look for the file node that corresponds to the definition of Main.main */
FileOffset
findMainUse (Bool findUse)
{
FileOffset fo;
FileOffset atom;
FileOffset def;
FileOffset use;
char c;
char *str;
// We should find the main module at 0x10
fseek(HatFileSeq,0x10,SEEK_SET); q_position=0x10;
q_fread(&c,sizeof(char),1,HatFileSeq);
assert (lower5(c)==Module, "Module tag");
str = q_readString();
assert (!strcmp(str,"Main"),"Module is Main");
// The next thing shoult be the atom variable belonging to that module
q_readString();
atom = q_position;
q_fread(&c,sizeof(char),1,HatFileSeq);
assert (lower5(c)==AtomVariable, "AtomVariable tag");
fo = q_readFO();
assert (fo==0x10, "AtomVariable module is Main");
{ /* skip defnpos */
int x;
q_fread(&x,sizeof(int),1,HatFileSeq);
}
{ /* skip defnpos */
int x;
q_fread(&x,sizeof(int),1,HatFileSeq);
}
{ /* skip fixity */
char x;
q_fread(&x,sizeof(char),1,HatFileSeq);
}
// Main takes no arguments
q_fread(&c,sizeof(char),1,HatFileSeq);
assert (c==0, "AtomVariable has arity 0");
// Make sure the deffinition is main
str = q_readString();
assert (!strcmp(str,"main"),"AtomVariable is main");
// Make sure there is a constant definition pointing at main
def = q_position;
q_fread(&c,sizeof(char),1,HatFileSeq);
assert (lower5(c)==ExpConstDef, "ExpConstDef tag");
q_readFO(); q_readFO();
fo = q_readFO();
assert (fo==atom, "ExpConstDef points to AtomVariable main");
// Make sure that main is called
use = q_position;
q_fread(&c,sizeof(char),1,HatFileSeq);
assert (lower5(c)==ExpConstUse, "ExpConstUse tag");
if (hasSrcPos(c)) q_readFO();
q_readFO();
fo = q_readFO();
assert(fo==def, "ExpConstUse points to ExpConstDef");
if (findUse)
{
return use;
}
else
{
return def;
}
/* postcondition: q_position points to first node following ExpConstUse */
}
/* getResultNoCycleHT actually does the leg-work of getting the function
* results. The old getResult used lots of calls like this to express
* recursion:
* return getResult(foo, bar);
* In order that the results are actually entered into the hash table,
* these have been replaced with:
* returnval = getResult(foo, bar);
* the value is then entered into the hash table once it has been
* aquired. The only problem is that, while the original version was
* probably compiled into constant-space iteration, this version can't be. So,
* with very large ART files, you will eventually end up with a huge number
* of calls to getResultNoCycleHT piling up on the stack, which may
* break black-hat / hat-nonterm in some horrible non-reproducible manner.
* However, this hasn't happened to me, yet.
*/
FileOffset
getResultNoCycleHT(FileOffset fo, Bool stopAtHidden)
{
char c;
FileOffset result, returnval;
nodecount++;
if (hashTable == NULL) hashTable = foInitTable(10000);
if ((returnval = foHashRetrieve(hashTable, fo)) != 0) return returnval;
if (fo<=DoLambda) return fixInterrupt(fo); /* trace is Unevaluated etc */
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result==fo) return fo;
else if (result<=DoLambda) return fixInterrupt(fo);
else returnval = getResultNoCycleHT(result,False);
break;
// case ExpValueApp:
// case ExpValueUse:
// if (hasSrcPos(c)) { readFO(); } /* skip use position */
// readFO(); /* skip parent */
// return readFO(); /* return Atom pointer */
// break;
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result<=DoLambda) return fixInterrupt(fo);
else returnval = getResultNoCycleHT(result,False);
/* follow ExpConstDef pointer */
break;
case ExpConstDef:
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result<=DoLambda) return fixInterrupt(fo);
returnval = getResultNoCycleHT(result,False);
break;
case ExpForward:
returnval = getResultNoCycleHT(readFO(),stopAtHidden);
break; /* continue to detect Hidden */
case ExpDoStmt:
returnval = getResultNoCycleHT(readFO(),False); /* get result */
break;
case ExpProjection:
return fo;
case ExpValueApp:
case ExpValueUse:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
// case AtomVariable:
// case AtomConstructor:
// case AtomAbstract:
return fo;
break;
case ExpHidden:
if (stopAtHidden) return fo;
// instead of returning the file offset of the hidden in the
// case of a loop, return the Entered filePointer
else if (fo==mostRecentHidden) return Entered;
else {
mostRecentHidden = fo; /* keep, to detect a loop */
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result==fo) return fo;
else if (result<=DoLambda) return fixInterrupt(fo);
else returnval = getResultNoCycleHT(result,False);
}
break;
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
returnval = 0;
break;
}
foHashInsert(hashTable, fo, returnval);
return returnval;
}
FileOffset
peekResultMod (FileOffset fo)
{
char c;
FileOffset result;
nodecount++;
//HIDE(fprintf(stderr,"peekResult 0x%x\n",fo);)
if (fo<=DoLambda) return fixInterrupt(fo); /* trace is Unevaluated etc */
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
break;
case ExpConstUse:
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
break;
case ExpConstDef:
readFO(); /* skip parent */
result = readFO(); /* get result */
break;
case ExpForward:
case ExpDoStmt:
result = readFO(); /* get result */
break;
case ExpValueApp:
case ExpValueUse:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
//HIDE(fprintf(stderr,"getResult: result is itself\n");)
result = fo;
break;
case ExpHidden:
readFO(); /* skip parent */
result = readFO(); /* get result */
break;
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
return 0;
break;
}
if (result<=DoLambda) return fixInterrupt(result);
freadAt(result,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpConstDef:
return peekResultMod(result);
break;
case ExpProjection:
return peekResultMod(result);
break;
default:
return fixInterrupt(result);
break;
}
}
/* This is a modified version of the Hat function getExpArg. The
* original function takes a filenode, and gets the value of a
* particular agument. However, it also followed some of the argument
* pointers, specifically the pointers for Expression Applications. This
* had some odd results for black-hat, so I've stopped it following most
* pointers. The getResultRestricted function takes the place of
* getResult, and only follows a small number of pointer-types.
*/
FileOffset
getImmediateExpArg (FileOffset fo, int n)
{
char c;
int i=0;
FileOffset ptr;
nodecount++;
//fprintf(stderr,"getExpArg 0x%x\n",fo);
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* fun/constructor */
if (n==0) return getResultRestricted(ptr);
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return getResultRestricted(ptr);
} else
return fo;
break;
case ExpValueApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* fun/constructor */
if (n==0) return ptr; /* no result-chain - fun is already an atom */
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return getResultRestricted(ptr);
} else
return fo;
break;
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* CAF */
return ptr; /* no result-chain - fun is already an atom */
break;
case ExpConstDef:
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* CAF */
return getResultRestricted(ptr);
break;
case ExpGuard:
case ExpCase:
case ExpIf:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get condition */
return getResult(ptr,True);
break;
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* exp/constructor */
if (n==0) return getResult(ptr,True);
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=0; i<c; i++) readFO(); /* skip binder labels */
for (i=1; i<n; i++) readFO(); /* skip other bindees */
ptr = readFO(); /* get n'th bindee */
return getResultRestricted(ptr);
} else
return fo;
break;
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpForward:
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpHidden:
case ExpDoStmt:
case Module:
case SrcPos:
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
return fo;
break;
}
}
/* q_oneNode() moves the file pointer past a single node in the file.
* As a side-effect, if it finds an AtomVariable or AtomConstructor,
* it adds it to the global structure 'map1'. If it finds an ExpValueUse
* or ExpConstDef, it adds an entry in map2 from that usage to the relevant
* Atom in map1. If it finds an ExpApp or ExpConstUse, it instead looks
* up the Atom ptr in map2, then looks up that Atom in map1, and finally
* increments the usage counter. However, in the case where an ExpApp
* is undersaturated (discovered by comparing its arity with the arity
* stored in map2), rather than incrementing the usage counter, we
* instead need to add the address of the ExpApp to map2.
*/
void
q_oneNode (void)
{
char c; int err;
FileOffset node = q_position;
/*fprintf(stdout,"\n0x%x: ",position); fflush(stdout);*/
err = q_fread(&c,sizeof(char),1,HatFileSeq);
if (err!=1) return;
switch (lower5(c)) { /* lower 5 bits identify the TraceType */
case ExpApp:
if (hasSrcPos(c)) { q_readFO(); }
q_readFO(); /* skip parent */
{ unsigned char size, next, i;
FileOffset fun, result; defn *def; item *it;
result = q_readFO(); /* get result */
fun = q_readFO(); /* keep fun ptr */
q_fread(&size,sizeof(unsigned char),1,HatFileSeq); /* get arity */
for (i=0; i<size; i++) q_readFO(); /* skip args */
def = (defn*)FM_lookup(map2,(cast)(uintptr_t)fun);
if (def) {
defn *def2;
it = FM_lookup(map1,(cast)(uintptr_t)def->atom);
if (it) {
if (size>=def->arity) {
if (result==Entered) it->pending += 1;
else if (result==Unevaluated) it->thunks += 1;
else it->uses += 1;
} else if (size < def->arity)
def2 = map2_insert(node,def->atom,size);
} else {
fprintf(stderr,"unknown atom in fun at (ExpApp 0x%x)\n",node);
}
if (def->next) {
it = FM_lookup(map1,(cast)(uintptr_t)def->next->atom);
if (it) {
if (size>=def->next->arity) {
if (result==Entered) it->pending += 1;
else if (result==Unevaluated) it->thunks += 1;
else it->uses += 1;
} else if (size < def->next->arity) {
def2->next = (defn*)malloc(sizeof(defn));
def2->next->atom = def->next->atom;
def2->next->arity = def->next->arity - size;
def2->next->next = (defn*)0;
}
} else {
fprintf(stderr,"unknown atom in CAF fun at (ExpApp 0x%x)\n",node);
}
}
} else {
// fprintf(stderr,"unknown fun at (ExpApp 0x%x)\n",node);
}
} break;
case ExpValueApp:
if (hasSrcPos(c)) { q_readFO(); }
q_readFO(); /* skip parent */
{ unsigned char size, next, i;
FileOffset fun; defn *def; item *it;
fun = q_readFO(); /* fun ptr is an Atom ref */
q_fread(&size,sizeof(unsigned char),1,HatFileSeq); /* get arity */
for (i=0; i<size; i++) q_readFO(); /* skip args */
it = FM_lookup(map1,(cast)(uintptr_t)fun);
if (it) {
if (size>=it->arity) {
it->uses += 1;
HIDE(fprintf(stderr,"0x%x ExpValueApp: incrementing\n",node);)
} else if (size < it->arity) {
map2_insert(node,fun,size);
HIDE(fprintf(stderr,"0x%x ExpValueApp: partial app\n",node);)
}
} else {
