/* 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;
}
/* 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;
}
}
/**
* Read a node from a hat file.
*
* @param hatFile The file to read from - assumed to be open.
* @param offset The offset to start reading in the hat file.
* @return A node pointer to the node found in the hatFile at offset.
*/
node* readNode (FILE *hatFile, unsigned long offset)
{
int err;
char b;
node *newNode;
// Find out which type of node we have.
fseek (hatFile, offset, SEEK_SET);
err = fread (&b, sizeof(char), 1, hatFile);
if (err != 1)
{
return NULL;
}
else
{
int tag = lower5(b);
if ((ExpDoStmt < tag && tag < AtomVariable) || tag > AtomAbstract)
{
fprintf (stderr, "strange tag %d at byte offset 0x%x\n", tag, offset);
exit (1);
}
switch (tag)
{
case AtomAbstract:
newNode = readAtomAbstract(hatFile, offset);
break;
case AtomConstructor:
newNode = readAtomConstructor(hatFile, offset);
break;
case AtomVariable:
newNode = readAtomVariable(hatFile, offset);
break;
case ExpApp:
newNode = readExpApp(hatFile, offset);
break;
case ExpCase:
newNode = readExpCase(hatFile, offset);
break;
case ExpChar:
newNode = readExpChar(hatFile, offset);
break;
case ExpConstDef:
newNode = readExpConstDef(hatFile, offset);
break;
case ExpConstUse:
newNode = readExpConstUse(hatFile, offset);
break;
case ExpDouble:
newNode = readExpDouble(hatFile, offset);
break;
case ExpDoStmt:
newNode = readExpDoStmt(hatFile, offset);
break;
case ExpFieldUpdate:
newNode = readExpFieldUpdate(hatFile, offset);
break;
case ExpFloat:
newNode = readExpFloat(hatFile, offset);
break;
case ExpForward:
newNode = readExpForward(hatFile, offset);
break;
case ExpGuard:
newNode = readExpGuard(hatFile, offset);
break;
case ExpHidden:
newNode = readExpHidden(hatFile, offset);
break;
case ExpIf:
newNode = readExpIf(hatFile, offset);
break;
case ExpInt:
newNode = readExpInt(hatFile, offset);
break;
case ExpInteger:
newNode = readExpInteger(hatFile, offset);
break;
case ExpProjection:
newNode = readExpProjection(hatFile, offset);
break;
case ExpRat:
newNode = readExpRat(hatFile, offset);
break;
case ExpRational:
newNode = readExpRational(hatFile, offset);
break;
case ExpValueApp:
newNode = readExpValueApp(hatFile, offset);
break;
case ExpValueUse:
newNode = readExpValueUse(hatFile, offset);
break;
case Module:
newNode = readModule(hatFile, offset);
break;
case SrcPos:
newNode = readSrcPos(hatFile, offset);
break;
}
return newNode;
}
}
/* 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 {
