diogo
/
yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

BEAM on YAP update.... 

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1387 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
rslopes 2005-09-08 22:36:16 +00:00
parent 4342ce5c09
commit 685ce0805f
9 changed files with 7127 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
BEAM/eam.h Normal file
View File

@ -0,0 +1,194 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam compiler data structures and routines *
*************************************************************************/
#define Print_Code 0
/* To help on compiler debuging
1 -> show predicates info
2 -> show YAP abstract machine code (YAAM)
4 -> show YAAM after transformation
8 -> show indexing code
16 -> show EAM intermediate code
32 -> show EAM intermediate code with direct_calls
128 -> show EAM abstrac machine code
*/
#define Variavel 1
#define Lista 2
#define Estrutura 4
#define Constante 8
typedef unsigned long Cell;
typedef struct PCODE{
struct PCODE *nextInst;
int op, new1;
unsigned long new4;
} CInstr;
struct Clauses {
unsigned int idx; /* info for indexing on first arg */
Cell val; /* atom or functor in first arg */
unsigned int nr_vars; /* nr of local vars */
struct Predicates *predi; /* predicate struct */
int side_effects; /* clause has side effects */
Cell *code;
struct Clauses *next; /* next clause within the same predicate */
};
struct HASH_TABLE {
Cell value;
Cell *code;
struct HASH_TABLE *next;
};
struct Predicates { /* To register information about predicates */
unsigned long id;
unsigned char *name;
unsigned int arity;
unsigned int nr_alt; /* nr of alternativas */
unsigned int calls; /* nr of existent calls to this predicate */
struct Clauses *first;
struct Clauses *last;
int idx; /* is code indexed ? 0= needs compilation -1= no indexing possible 1= indexed */
unsigned int idx_var; /* nr clauses with 1st argument var */
unsigned int idx_list; /* nr clauses with 1st argument list */
unsigned int idx_atom; /* nr clauses with 1st argument atom */
unsigned int idx_functor; /* nr clauses with 1st argument functor */
short int eager_split; /* allow eager splitting */
Cell *code; /* try, retry and trust code or Indexing code */
struct HASH_TABLE **atom;
struct HASH_TABLE **functor;
Cell *list;
Cell *vars;
struct Predicates *next;
};
/**************************** EAM TRUE STUFF *************/
struct SUSPENSIONS {
struct AND_BOX *and_box; /* And_box where the variable has suspended */
short int reason; /* suspended before executing call number nr_call */
struct SUSPENSIONS *next; /* Pointer to the next suspention */
struct SUSPENSIONS *prev;
};
struct SUSPENSIONS_VAR {
struct AND_BOX *and_box; /* And_box where the variable has suspended */
struct SUSPENSIONS_VAR *next; /* Pointer to the next suspention */
};
struct PERM_VAR {
Cell value; /* value assigned to the variable */
struct AND_BOX *home; /* pointer to the goal_box structure of the variable */
Cell *yapvar;
struct SUSPENSIONS_VAR *suspensions; /* Pointer to a Suspension List */
struct PERM_VAR *next;
};
struct EXTERNAL_VAR { /* to be used as some kind of trail */
Cell value; /* value assign to the variable */
struct PERM_VAR *var; /* pointer to the local_var struct */
struct EXTERNAL_VAR *next;
};
struct status_and {
struct OR_BOX *call; /* POINTER TO A OR_BOX */
Cell *locals; /* temporary vars vector */
Cell *code; /* Pointer to the start code */
int state; /* State of the OR_BOX */
struct status_and *previous;
struct status_and *next;
};
struct status_or {
struct AND_BOX *alternative; /* POINTER TO A AND_BOX */
Cell *args; /* Saved Arguments */
Cell *code; /* Pointer to Start Code */
int state; /* State of the AND_BOX */
struct status_or *previous;
struct status_or *next;
};
struct OR_BOX {
struct AND_BOX *parent;
struct status_and *nr_call; /* order of this box */
short int nr_all_alternatives; /* number of existing alternatives */
struct status_or *alternatives; /* alternatives of the or_box */
short int eager_split;
};
struct AND_BOX {
struct OR_BOX *parent; /* pointer to the parent or-box */
struct status_or *nr_alternative; /* This box is alternative id */
short int nr_all_calls; /* numger of all goals */
struct PERM_VAR *perms;
struct status_and *calls;
short int level; /* indicates the level in the tree */
struct EXTERNAL_VAR *externals; /* pointer to a list of external_vars */
struct SUSPENSIONS *suspended; /* pointer to a list of suspended boxes */
short int side_effects; /* to mark if are calls to builtins with side_efects (like write) */
};
/* TYPE OF STATES */
#define ZERO 0 /* No State yet */
#define SUCCESS 1
#define FAILS 2
#define READY 4 /* Is ready to start execution */
#define RUNNING 8 /* Is running */
#define RUNAGAIN 16 /* Is running again */
#define SUSPEND 32 /* Has suspended */
#define WAKE 64 /* Was Suspended, but now is Ready again */
#define CHANGED 128 /* Has received some change on it's external variables, needs to re-run */
#define END 256 /* Has suspended on end, on wake up can pass to a success state */
#define WAITING 512 /* The clause is waiting for the previous predicates to leave the Suspended state */
#define FAILED 1024 /* has failed */
#define CUT_RIGHT 2048
#define SKIP_VAR 4096
#define LEFTMOST_PARENT 8192
#define FIRST 16384
#define LEFTMOST 32768
#define WAITING_TO_BE_FIRST (WAITING + FIRST)
#define WAITING_TO_BE_LEFTMOST (WAITING + LEFTMOST)
#define WAITING_TO_BE_LEFTMOST_PARENT (WAITING + LEFTMOST_PARENT)
#define WAITING_TO_CUT (WAITING + CUT_RIGHT)
#define WAITING_SKIP_VAR (WAITING + SKIP_VAR)
#define SUSPEND_END (SUSPEND+END)
#define WAKE_END (WAKE+END)
#define NORMAL_SUSPENSION 0
#define LEFTMOST_SUSPENSION 1
#define WAIT_SUSPENSION 2
#define CUT_SUSPENSION 3
#define WRITE_SUSPENSION 4
#define VAR_SUSPENSION 5
#define YAP_VAR_SUSPENSION 6
/* TYPE OF SIDE_EFFECTS */
#define WRITE 1
#define COMMIT 2
#define VAR 4
#define SEQUENCIAL 8
#define CUT 32 /* Greater than 32 always cut */

3804
BEAM/eam_am.c Normal file
View File

File diff suppressed because it is too large Load Diff

492
BEAM/eam_gc.c Normal file
View File

@ -0,0 +1,492 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: garbage collector routines *
*************************************************************************/
void garbage_collector(void);
struct OR_BOX *move_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call);
struct AND_BOX *move_andbox(struct AND_BOX *a,struct OR_BOX *parent,struct status_or *alt);
Cell refresh_structures(Cell c);
Cell move_structures(Cell c);
void refresh_andbox(struct AND_BOX *a);
void refresh_orbox(struct OR_BOX *o);
Cell refresh_structures(Cell c)
{
Cell *C, OldC;
OldC=deref((Cell) c);
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
if (isappl(OldC)) {
int i,arity;
C=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *C));
for(i=0;i<arity ;i++) {
C++;
*C=refresh_structures((Cell) C);
}
return(OldC);
}
/* else if (ispair(c)) { */
C=(Cell *) reppair(OldC);
*C=refresh_structures((Cell) C);
C++;
*C=refresh_structures((Cell) C);
return(OldC);
}
Cell move_structures(Cell c)
{
Cell *NewC, *NewH;
Cell OldC,OldH;
OldC=deref((Cell) c);
/*
if (MEM_Going==1 && ((unsigned long) OldC) <START_ADDR_HEAP+MEM_H/2) return(OldC);
if (MEM_Going==-1 && ((unsigned long) OldC)>=START_ADDR_HEAP+MEM_H/2 && ((unsigned long) OldC) <START_ADDR_BOXES) return(OldC);
*/
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
OldH=(Cell) _H;
NewH=_H;
if (isappl(OldC)) {
int i,arity;
NewC=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *NewC));
*NewH++=*NewC++;
_H+=arity+1;
for(i=0;i<arity ;i++) {
*NewH=move_structures((Cell) NewC);
NewH++;
NewC++;
}
return(absappl(OldH));
}
/* else if (ispair(c)) { */
NewC=(Cell *) reppair(OldC);
_H+=2;
*NewH=move_structures((Cell) NewC);
NewC++;
NewH++;
*NewH=move_structures((Cell) NewC);
return(abspair(OldH));
}
void garbage_collector()
{
#if GARBAGE_COLLECTOR==2
struct AND_BOX *new_top;
#endif
if (Mem_FULL & 2) nr_call_gc_heap++; else nr_call_gc_boxed++;
#if Debug || Debug_GC
printf("Entering Garbage Collector for the %dth time (Reason=%d)\n",nr_call_gc_heap+nr_call_gc_boxed,Mem_FULL);
#endif
#if Debug_Dump_State & 2
dump_eam_state();
printf("--------------------------------------------------------------------\n");
#endif
Mem_FULL=0;
#if Memory_Stat
if (MEM_Going==1) {
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][1]=(unsigned long) _H-START_ADDR_HEAP;
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][2]=(unsigned long) Next_Free-START_ADDR_BOXES;
} else {
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][1]=(unsigned long) _H-START_ADDR_HEAP-MEM_H/2;
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][2]=END_BOX- ((unsigned long) Next_Free);
}
if (GARBAGE_COLLECTOR==1)
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][2]=END_BOX- ((unsigned long) Next_Free);
#endif
#if GARBAGE_COLLECTOR==1
if (MEM_Going==1) {
if (_H < (Cell *) (START_ADDR_HEAP+MEM_H/2)) _H=(Cell *) (START_ADDR_HEAP+MEM_H/2); else _H++;
MEM_Going=-1;
} else {
_H=(Cell *) START_ADDR_HEAP;
MEM_Going=1;
}
refresh_andbox(top);
#if Clear_MEMORY
if (MEM_Going==-1) {
memset(START_ADDR_HEAP,0,MEM_H/2);
} else {
memset(START_ADDR_HEAP+MEM_H/2,0,MEM_H/2);
}
#endif
#else
memset(Index_Free,0,INDEX_SIZE*POINTER_SIZE);
if (MEM_Going==1) {
if (_H < (Cell *) (START_ADDR_HEAP+MEM_H/2)) _H=(Cell *) (START_ADDR_HEAP+MEM_H/2); else _H++;
Next_Free=(Cell *)END_BOX;
MEM_Going=-1;
} else {
if (_H>=(Cell *) START_ADDR_BOXES) Next_Free=_H+1; else Next_Free=(Cell *) START_ADDR_BOXES;
_H=(Cell *) START_ADDR_HEAP;
MEM_Going=1;
}
Mem_FULL=0;
SU=NULL;
new_top=move_andbox(top,NULL,NULL);
top=new_top;
#if Clear_MEMORY
if (MEM_Going==-1) {
memset((void *) START_ADDR_HEAP,0,MEM_H/2);
memset((void *) START_ADDR_BOXES,0,MEM_BOXES/2);
} else {
memset((void *) START_ADDR_HEAP+MEM_H/2,0,MEM_H/2);
memset((void *) START_ADDR_BOXES+MEM_BOXES/2,0,MEM_BOXES/2);
}
#endif
#endif
#if Memory_Stat
if (MEM_Going==1) {
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][3]=(unsigned long) _H-START_ADDR_HEAP;
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][4]=(unsigned long) Next_Free-START_ADDR_BOXES;
} else {
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][3]=(unsigned long) _H-START_ADDR_HEAP-MEM_H/2;
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][4]=END_BOX- ((unsigned long) Next_Free);
}
if (GARBAGE_COLLECTOR==1)
Memory_STAT[nr_call_gc_heap+nr_call_gc_boxed][4]=END_BOX- ((unsigned long) Next_Free);
#endif
#if Debug_Dump_State & 2
dump_eam_state();
#endif
#if Debug
printf("End of Garbage Collector\n");
#endif
}
#if GARBAGE_COLLECTOR!=1
struct OR_BOX *move_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call)
{
struct OR_BOX *new_orbox;
struct status_or *old, *new, *first=NULL, *last=NULL;
Cell *args,*newargs;
if (o==NULL) return(NULL);
#if !Fast_go
if ((Cell *) o<(Cell *) START_ADDR_BOXES || (Cell *) o>(Cell *) END_BOX) return (NULL);
#endif
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (OBX==o) OBX=new_orbox;
new_orbox->parent=parent;
new_orbox->nr_call=nr_call;
new_orbox->nr_all_alternatives=o->nr_all_alternatives;
old=o->alternatives;
while(old!=NULL) {
new=(struct status_or *) request_memory(STATUS_OR_SIZE);
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (nr_alternative==old) nr_alternative=new;
new->args=old->args;
new->code=old->code;
new->state=old->state;
new->alternative=move_andbox(old->alternative,new_orbox,new);
if (first==NULL) first=new;
else last->next=new;
new->previous=last;
new->next=NULL;
last=new;
old=old->next;
}
new_orbox->alternatives=first;
args=NULL;
newargs=NULL;
while(last!=NULL) {
if (last->args==NULL) {
args=NULL;
newargs=NULL;
} else if (args!=last->args) {
int y;
args=last->args;
#if Debug
printf("Request args=%d \n",(int) args[0]);
#endif
newargs=(Cell *)request_memory((args[0])*sizeof(Cell));
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
newargs[0]=args[0];
for(y=1;y<args[0];y++) newargs[y]=move_structures(args[y]);
}
last->args=newargs;
last=last->previous;
}
return(new_orbox);
}
struct AND_BOX *move_andbox(struct AND_BOX *a,struct OR_BOX *parent, struct status_or *alt )
{
int OLD_VAR_TRAIL_NR;
struct AND_BOX *new_andbox;
struct PERM_VAR *l;
struct EXTERNAL_VAR *old_externals,*externals;
if (a==NULL) return(NULL);
OLD_VAR_TRAIL_NR=VAR_TRAIL_NR;
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
if (ABX==a) ABX=new_andbox;
new_andbox->parent=parent;
new_andbox->nr_alternative=alt;
new_andbox->level=a->level;
new_andbox->side_effects=a->side_effects;
new_andbox->suspended=NULL;
if (a->suspended) {
new_andbox->suspended=addto_suspensions_list(new_andbox,a->suspended->reason);
}
new_andbox->perms=a->perms;
l=a->perms;
while(l!=NULL) { /* ainda nao estou a fazer GC nas Var Perm */
l->value=move_structures(l->value);
l->home=new_andbox;
l->suspensions=NULL;
l=l->next;
}
old_externals=a->externals;
externals=NULL;
while(old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->next=externals;
externals=e;
e->value=move_structures(old_externals->value);
e->var=(struct PERM_VAR *) old_externals->var;
//e->var=(struct PERM_VAR *) old_externals->var; CUIDADO QUANDO FIZER GC PERM_VARS
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE);
s->and_box=new_andbox;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
new_andbox->externals=externals;
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
/* CUIDADO: Preciso agora de duplicar os vectores das variaveis locais */
{ struct status_and *calls;
#if !Fast_go
Cell **backup=NULL; int i, counted=0,max=1000;
backup=(Cell **) malloc(max);
#else
Cell *backup[1000]; int i, counted=0;
#endif
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL) {
/* primeiro vou ver se já foi copiado */
for(i=0;i<counted;i+=2) {
if (backup[i]==calls->locals) {
calls->locals=backup[i+1];
break;
}
}
if (i==counted) { /* afinal ainda nao foi copiado: fazer copia em duas fases*/
Cell *c, *newvars, *oldvars; int nr;
oldvars=calls->locals;
nr=oldvars[-1];
newvars=request_memory_locals(nr,1);
if (var_locals==oldvars) var_locals=newvars;
calls->locals=newvars;
/* primeiro actualizo as variaveis */
for(i=0;i<nr;i++) {
c=&oldvars[i];
if ((Cell *)*c==c) {
newvars[i]=(Cell) &newvars[i];
*c=newvars[i];
} else {
newvars[i]= (Cell) *c;
*c=(Cell) &newvars[i];
}
}
/* depois copio as estruturas */
for(i=0;i<nr;i++) {
newvars[i]=move_structures(oldvars[i]);
}
#if !Fast_go
if (max<counted+2) {
max+=200;
backup=realloc(backup,max);
if (backup==NULL) abort_eam("No more memory... realloc in gc \n");
}
#else
if (counted>=998) abort_eam("No more memory... realloc in gc \n");
#endif
backup[counted]=oldvars;
backup[counted+1]=newvars;
counted+=2;
}
}
calls=calls->next;
}
#if !Fast_go
free(backup);
#endif
}
new_andbox->nr_all_calls=a->nr_all_calls;
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=a->calls;
while(calls!=NULL){
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
if (Mem_FULL) abort_eam("Sem Memoria para GC\n");
calls_new->code=calls->code;
calls_new->state=calls->state;
calls_new->locals=calls->locals;
if (nr_call==calls) nr_call=calls_new;
calls_new->call=move_orbox(calls->call,new_andbox,calls_new);
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
return(new_andbox);
}
#else /* used by GC Only on Heap || Keep boxes on same memory */
void refresh_orbox(struct OR_BOX *o)
{
struct status_or *old, *last=NULL;
Cell *args;
if (o==NULL) return;
old=o->alternatives;
while(old!=NULL) {
refresh_andbox(old->alternative);
last=old;
old=old->next;
}
args=NULL;
while(last!=NULL) {
if (last->args==NULL) {
args=NULL;
}else if (args!=last->args) {
int y;
args=last->args;
for(y=1;y<args[0];y++) {
args[y]=move_structures(args[y]);
}
}
last=last->previous;
}
return;
}
void refresh_andbox(struct AND_BOX *a)
{
struct PERM_VAR *l;
struct EXTERNAL_VAR *externals;
struct status_and *calls;
if (a==NULL) return;
l=a->perms;
while(l!=NULL) {
l->value=move_structures(l->value);
l=l->next;
}
externals=a->externals;
while(externals) {
externals->value=move_structures(externals->value);
externals=externals->next;
}
calls=a->calls;
while(calls!=NULL) {
// if (calls->calls!=NULL) {
if (calls->locals!=NULL && ((int) calls->locals[-1]>0) {
int nr,i;
nr=calls->locals[-1];
calls->locals[-1]=-nr;
for(i=0;i<nr;i++) {
calls->locals[i]=move_structures(calls->locals[i]);
}
}
refresh_orbox(calls->call);
// }
calls=calls->next;
}
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL && ((int) calls->locals[-1])<0) {
int nr;
nr=calls->locals[-1];
calls->locals[-1]=-nr;
}
calls=calls->next;
}
return;
}
#endif

374
BEAM/eam_showcode.c Normal file
View File

@ -0,0 +1,374 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam show abstract machine assembler *
*************************************************************************/
#ifdef BEAM
#include<stdio.h>
#include "Yap.h"
#include "Yatom.h"
#include "eam.h"
#include "eamamasm.h"
void eam_showcode(Cell *code);
extern int am_to_inst(Cell inst);
void eam_showcode(Cell *code)
{
int n;
#define arg1 *(code+1)
#define arg2 *(code+2)
#define arg3 *(code+3)
#define arg4 *(code+4)
printf("--------------------------------------------------\n");
while (1) {
n=am_to_inst(*code);
printf("%ld->",(long) code);
switch(n) {
case(_exit_eam):
printf("_exit\n");
code++;
if (*(code)==-1) return;
break;
case(_top_tree):
printf("_top_tree \n");
code++;
break;
case(_scheduler):
printf("_scheduler \n");
code++;
break;
case(_prepare_tries):
printf("_prepare_tries for %d clauses with arity=%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_prepare_calls ):
printf("_prepare_calls %d \n",(int) arg1);
code+=2;
break;
case(_get_var_X_op ):
printf("_get_var_X_op X%d, X%d\n",(int) arg1,(int) arg2);
code+=3;
break;
case(_get_var_Y_op ):
printf("_get_var_Y_op X%d, Y%d\n",(int) arg1,(int) arg2);
code+=3;
break;
case(_get_val_X_op ):
printf("_get_val_X_op X%d, X%d\n",(int) arg1,(int) arg2);
code+=3;
break;
case(_get_val_Y_op ):
printf("_get_val_Y_op X%d, Y%d\n",(int) arg1,(int) arg2);
code+=3;
break;
case(_get_atom_op ):
printf("_get_atom_op X%d, %d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_get_list_op ):
printf("_get_list_op X%d\n",(int) arg1);
code+=2;
break;
case(_get_struct_op ):
printf("_get_struct_op X%d, %lX/%d\n",(int) arg1,(unsigned long) arg2,(int) arg3);
code+=4;
break;
case(_unify_void_op ):
printf("_unify_void_op\n");
code++;
break;
case(_unify_val_X_op ):
printf("_unify_val_X_op X%d\n",(int) arg1);
code+=2;
break;
case(_unify_val_Y_op ):
printf("_unify_val_Y_op Y%d\n",(int) arg1);
code+=2;
break;
case(_unify_var_X_op ):
printf("_unify_var_X_op X%d\n",(int) arg1);
code+=2;
break;
case(_unify_var_Y_op ):
printf("_unify_var_Y_op Y%d\n",(int) arg1);
code+=2;
break;
case(_unify_atom_op ):
printf("_unify_atom_op 0x%lX\n",(unsigned long) arg1);
code+=2;
break;
case(_unify_list_op ):
printf("_unify_list_op \n");
code++;
break;
case(_unify_last_list_op ):
printf("_unify_last_list_op \n");
code++;
break;
case(_unify_struct_op ):
printf("_unify_struct_op 0x%lX,%d\n",(unsigned long) arg1,(int) arg2);
code+=3;
break;
case(_unify_last_struct_op ):
printf("_unify_last_struct_op 0x%lX,%d\n",(unsigned long) arg1,(int) arg2);
code+=3;
break;
case(_unify_last_atom_op ):
printf("_unify_last_atom_op 0x%lX\n",(unsigned long) arg1);
code+=2;
break;
case(_unify_local_X_op ):
printf("_unify_local_X_op X%d\n",(int) arg1);
code+=2;
break;
case(_unify_local_Y_op ):
printf("_unify_local_Y_op X%d\n",(int) arg1);
code+=2;
break;
case(_put_var_X_op ):
printf("_put_var_X_op X%d,X%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_var_Y_op ):
printf("_put_var_Y_op X%d,Y%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_var_P_op ):
printf("_put_var_P_op X%d,Y%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_val_X_op ):
printf("_put_val_X_op X%d,X%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_val_Y_op ):
printf("_put_val_Y_op X%d,Y%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_atom_op ):
printf("_put_atom_op X%d, %d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_put_list_op ):
printf("_put_list_op X%d \n",(int) arg1);
code+=2;
break;
case(_put_struct_op ):
printf("_put_struct_op X%d,%d,%d \n",(int) arg1,(int) arg2,(int) arg3);
code+=4;
break;
case(_put_unsafe_op ):
printf("_put_unsafe_op X%d, Y%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_write_void ):
printf("_write_void \n");
code++;
break;
case(_write_var_X_op ):
printf("_write_var_X_op X%d \n",(int) arg1);
code+=2;
break;
case(_write_var_Y_op ):
printf("_write_var_Y_op Y%d \n",(int) arg1);
code+=2;
break;
case(_write_var_P_op ):
printf("_write_var_P_op Y%d \n",(int) arg1);
code+=2;
break;
case(_write_val_X_op ):
printf("_write_val_X_op X%d \n",(int) arg1);
code+=2;
break;
case(_write_val_Y_op ):
printf("_write_val_Y_op Y%d \n",(int) arg1);
code+=2;
break;
case(_write_atom_op ):
printf("_write_atom_op %d \n",(int) arg1);
code+=2;
break;
case(_write_list_op ):
printf("_write_list_op \n");
code++;
break;
case(_write_struct_op ):
printf("_write_struct_op %d,%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_write_last_list_op ):
printf("_write_last_list_op \n");
code++;
break;
case(_write_last_struct_op ):
printf("_write_last_struct_op %d,%d \n",(int) arg1,(int) arg2);
code+=3;
break;
case(_write_local_X_op ):
printf("_write_local_X_op X%d \n",(int) arg1);
code+=2;
break;
case(_write_local_Y_op ):
printf("_write_local_Y_op Y%d \n",(int) arg1);
code+=2;
break;
case(_pop_op ):
printf("_pop_read_op \n");
code++;
break;
case(_jump_op ):
printf("_jump_op %ld\n",(long int) arg1);
code+=4;
break;
case(_proceed_op ):
printf("_proceed_op \n");
code++;
break;
case(_call_op ):
printf("_call_op %s/%d \n", ((PredEntry *) arg1)->beamTable->name,((PredEntry *) arg1)->beamTable->arity);
code+=2;
break;
case(_safe_call_op ):
printf("_safe_call_op %ld \n",(long) arg1);
code+=2;
break;
case(_safe_call_unary_op ):
printf("_safe_call_unary_op %ld \n",(long) arg1);
code+=2;
break;
case(_safe_call_binary_op ):
printf("_safe_call_binary_op %ld \n",(long) arg1);
code+=2;
break;
case(_only_1_clause_op ):
printf("_only_1_clause_op -> Use the same AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
code+=4;
break;
case(_try_me_op ):
printf("_try_me_op -> Create AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
code+=5;
break;
case(_retry_me_op ):
printf("_retry_me_op -> Create AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
code+=5;
break;
case(_trust_me_op ):
printf("_trust_me_op -> Create AND_BOX for the %dth clause of predicate %s/%d (Yvars=%d) \n",(int) arg4,((struct Clauses *)arg1)->predi->name,(int) arg2,(int) arg3);
code+=5;
break;
case(_do_nothing_op ):
printf("do_nothing_op \n");
code++;
break;
case(_direct_safe_call_op ):
printf("_direct_safe_call_op %ld \n",(long) arg1);
code+=2;
break;
case(_direct_safe_call_unary_op ):
printf("_direct_safe_call_unary_op %ld \n",(long) arg1);
code+=2;
break;
case(_direct_safe_call_binary_op ):
printf("_direct_safe_call_binary_op %ld \n",(long) arg1);
code+=2;
break;
case(_skip_while_var ):
printf("_skip_while_var \n");
code++;
break;
case(_wait_while_var ):
printf("_wait_while_var \n");
code++;
break;
case(_force_wait ):
printf("_force_wait \n");
code++;
break;
case(_write_call ):
printf("_write_call \n");
code++;
break;
case(_is_call ):
printf("_is_call \n");
code++;
break;
case(_equal_call ):
printf("_equal_call \n");
code++;
break;
case(_cut_op ):
printf("_cut_op \n");
code++;
break;
case(_commit_op ):
printf("_commit_op \n");
code++;
break;
case(_fail_op ):
printf("_fail_op \n");
code++;
break;
case(_save_b_X_op ):
printf("_save_b_X_op \n");
code++;
break;
case(_save_b_Y_op ):
printf("_save_b_Y_op \n");
code++;
break;
case(_save_appl_X_op ):
printf("_save_appl_X_op \n");
code++;
break;
case(_save_appl_Y_op ):
printf("_save_appl_Y_op \n");
code++;
break;
case(_save_pair_X_op ):
printf("_save_pair_X_op \n");
code++;
break;
case(_save_pair_Y_op ):
printf("_save_pair_Y_op \n");
code++;
break;
case(_either_op ):
printf("_either_op \n");
code++;
break;
case(_orelse_op ):
printf("_orelse_op \n");
code++;
break;
case(_orlast_op ):
printf("_orlast_op \n");
code++;
break;
default:
if (n!=*code) printf("inst(%d)\n",n);
else printf("Label Next Call %d\n",n);
code++;
}
}
}
#endif /* BEAM */

478
BEAM/eam_split.c Normal file
View File

@ -0,0 +1,478 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: split related functions *
*************************************************************************/
void do_forking_andbox(struct AND_BOX *a);
Cell copy_structures(Cell c);
void replicate_local_variables(struct AND_BOX *a);
struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call);
struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent);
void do_forking_andbox(struct AND_BOX *a)
{
struct OR_BOX *op,*opp, *new_orbox;
struct AND_BOX *ap, *new_andbox;
int nr_all_alternatives, nr_all_calls;
struct status_and *nr_call,*new_call;
struct status_or *nr_alternative, *alternatives, *new_alternatives;
nr_call_forking++;
op=a->parent; /* or box parent */
ap=op->parent; /* and box parent */
opp=ap->parent; /* or box parent parent */
if (opp==NULL) {
abort_eam("Forking with orbox parent parent NULL, maybe I'm on top ?????");
}
alternatives=opp->alternatives;
nr_all_alternatives=opp->nr_all_alternatives;
nr_alternative=ap->nr_alternative;
nr_all_calls=ap->nr_all_calls;
nr_call=op->nr_call;
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
new_andbox->parent=opp;
// new_andbox->nr_alternative=nr_alternative; /* seted after creating a new status_or */
new_andbox->nr_all_calls=nr_all_calls;
new_andbox->level=ap->level;
new_andbox->perms=ap->perms;
new_andbox->suspended=NULL;
if (ap->suspended) new_andbox->suspended=addto_suspensions_list(new_andbox,ap->suspended->reason);
new_andbox->side_effects=ap->side_effects;
if (ap->externals) {
struct EXTERNAL_VAR *old_externals, *list=NULL;
old_externals=ap->externals;
while (old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->value=old_externals->value;
e->var=(struct PERM_VAR *) old_externals->var;
e->next=list;
list=e;
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=new_andbox;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
new_andbox->externals=list;
} else new_andbox->externals=NULL;
new_call=(struct status_and *) request_memory(STATUS_AND_SIZE);
new_call->call=new_orbox;
new_call->locals=nr_call->locals;
new_call->code=nr_call->code;
new_call->state=WAKE;
nr_call->state=WAKE; /* NEW PARA TORNAR A CALL NUM WAKE STATE */
new_orbox->parent=new_andbox;
new_orbox->nr_call=new_call;
new_orbox->nr_all_alternatives=1;
new_alternatives=a->nr_alternative;
new_orbox->alternatives=new_alternatives;
/* remove andbox from op */
op->nr_all_alternatives-=1;
if (new_alternatives->previous==NULL) op->alternatives=new_alternatives->next;
else new_alternatives->previous->next=new_alternatives->next;
if (new_alternatives->next!=NULL) new_alternatives->next->previous=new_alternatives->previous;
new_alternatives->next=NULL;
new_alternatives->previous=NULL;
a->parent=new_orbox;
/* increase the nr_alternatives by 1 in opp or_box parent parent and conect new_andbox*/
new_alternatives=(struct status_or *) request_memory(STATUS_OR_SIZE);
new_andbox->nr_alternative=new_alternatives;
new_alternatives->next=nr_alternative;
new_alternatives->previous=nr_alternative->previous;
if (nr_alternative->previous==NULL) opp->alternatives=new_alternatives;
else nr_alternative->previous->next=new_alternatives;
nr_alternative->previous=new_alternatives;
new_alternatives->args=nr_alternative->args;
new_alternatives->code=nr_alternative->code;
new_alternatives->state=nr_alternative->state;
new_alternatives->alternative=new_andbox;
opp->nr_all_alternatives=nr_all_alternatives+1;
/* copy and_box ap to new_and-box */
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=ap->calls;
while(calls!=NULL) {
if (calls==nr_call) {
calls_new=new_call;
} else {
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
calls_new->code=calls->code;
calls_new->locals=calls->locals;
calls_new->state=calls->state;
calls_new->call=copy_orbox(calls->call,new_andbox,calls_new); /* Do a exact copy of the tree*/
}
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
/* remove and_box a from suspension list on vars */
if (a->externals) {
struct EXTERNAL_VAR *e;
e=a->externals;
while(e) {
if (e->var->home->level>=a->parent->parent->level)
remove_from_perm_var_suspensions(e->var,a);
e=e->next;
}
}
/* Now we have to create new local vars and refresh the external vars to point to those */
if (MEM_Going==1) {
VAR_TRAIL=((Cell *) START_ADDR_BOXES)-1;
} else VAR_TRAIL=(Cell *) START_ADDR_HEAP;
VAR_TRAIL_NR=0;
replicate_local_variables(new_andbox);
}
struct OR_BOX *copy_orbox(struct OR_BOX *o,struct AND_BOX *parent,struct status_and *nr_call)
{
struct OR_BOX *new_orbox;
struct status_or *old,*new,*first=NULL,*last=NULL;
if (o==NULL) return(NULL);
new_orbox=(struct OR_BOX *) request_memory(ORBOX_SIZE);
new_orbox->parent=parent;
new_orbox->nr_call=nr_call;
new_orbox->nr_all_alternatives=o->nr_all_alternatives;
old=o->alternatives;
while(old!=NULL) {
new=(struct status_or *) request_memory(STATUS_OR_SIZE);
new->args=old->args;
new->code=old->code;
new->state=old->state;
new->alternative=copy_andbox(old->alternative,new_orbox);
if (new->alternative!=NULL) new->alternative->nr_alternative=new;
if (first==NULL) first=new;
else last->next=new;
new->previous=last;
new->next=NULL;
last=new;
old=old->next;
}
new_orbox->alternatives=first;
return(new_orbox);
}
struct AND_BOX *copy_andbox(struct AND_BOX *a,struct OR_BOX *parent)
{
struct AND_BOX *new_andbox;
if (a==NULL) return(NULL);
new_andbox=(struct AND_BOX *) request_memory(ANDBOX_SIZE);
new_andbox->parent=parent;
// new_andbox->nr_alternative=a->nr_alternative; /* this is seted in the copy_orbox, after calling copy_andbox */
new_andbox->nr_all_calls=a->nr_all_calls;
new_andbox->level=a->level;
new_andbox->perms=a->perms;
new_andbox->externals=a->externals;
new_andbox->side_effects=a->side_effects;
new_andbox->suspended=NULL;
if (a->suspended) {
new_andbox->suspended=addto_suspensions_list(new_andbox,a->suspended->reason);
}
{ struct status_and *first=NULL, *last=NULL,*calls,*calls_new;
calls=a->calls;
while(calls!=NULL) {
calls_new=(struct status_and *) request_memory(STATUS_AND_SIZE);
calls_new->code=calls->code;
calls_new->locals=calls->locals;
calls_new->state=calls->state;
calls_new->call=copy_orbox(calls->call,new_andbox,calls_new); /* Do a exact copy of the tree*/
if (first==NULL) first=calls_new;
else last->next=calls_new;
calls_new->previous=last;
calls_new->next=NULL;
last=calls_new;
calls=calls->next;
}
new_andbox->calls=first;
}
return(new_andbox);
}
void replicate_local_variables(struct AND_BOX *a) /* used by fork -ABX is set*/
{
struct PERM_VAR *l,*new_list;
int i,OLD_VAR_TRAIL_NR;
struct EXTERNAL_VAR *old_externals,*externals;
if (a==NULL) return;
OLD_VAR_TRAIL_NR=VAR_TRAIL_NR;
l=a->perms;
new_list=NULL;
while(l) {
struct PERM_VAR *new;
Cell *c;
new=request_permVar(a);
new->yapvar=l->yapvar;
new->next=new_list;
new_list=new;
c=&l->value;
VAR_TRAIL[VAR_TRAIL_NR]=(Cell) c;
VAR_TRAIL_NR-=MEM_Going;
VAR_TRAIL[VAR_TRAIL_NR]=(Cell) *c;
VAR_TRAIL_NR-=MEM_Going;
if ((Cell *)*c==c) {
new->value=(Cell) &new->value;
*c=new->value;
} else {
new->value= (Cell) *c;
*c=(Cell) &new->value;
}
l=l->next;
}
a->perms=new_list;
l=new_list;
while(l) {
l->value=copy_structures(l->value);
l=l->next;
}
/* At this point all old local vars are pointing to the new local vars */
if (a==ABX) { /* Nao preciso de criar um novo vector das externals */
old_externals=a->externals;
while(old_externals) {
if (old_externals->var->home->level>=ABX->parent->parent->level) {
old_externals->value=copy_structures((Cell ) old_externals->value);
old_externals->var=(struct PERM_VAR *) old_externals->var->value;
if (isvar(old_externals->var)) {
struct SUSPENSIONS_VAR *s;
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=a;
s->next=old_externals->var->suspensions;
old_externals->var->suspensions=s;
}
}
old_externals=old_externals->next;
}
} else {
old_externals=a->externals;
externals=NULL;
a->externals=NULL;
while(old_externals) {
struct EXTERNAL_VAR *e;
struct SUSPENSIONS_VAR *s;
e=(struct EXTERNAL_VAR *) request_memory(EXTERNAL_VAR_SIZE);
e->next=externals;
externals=e;
if (old_externals->var->home->level>=ABX->parent->parent->level) {
e->value=copy_structures((Cell ) old_externals->value);
e->var=(struct PERM_VAR *) old_externals->var->value;
} else {
e->value=old_externals->value;
e->var=(struct PERM_VAR *) old_externals->var->value;
}
if (isvar(e->var)) {
s=(struct SUSPENSIONS_VAR *) request_memory(SUSPENSIONS_VAR_SIZE); /* Add and_box to suspension list of var*/
s->and_box=a;
s->next=e->var->suspensions;
e->var->suspensions=s;
}
old_externals=old_externals->next;
}
a->externals=externals;
}
/* CUIDADO: Preciso agora de duplicar os vectores das variaveis locais */
{ struct status_and *calls;
#if !Fast_go
Cell **backup=NULL; int i, counted=0,max=1000;
backup=(Cell **) malloc(max);
#else
Cell *backup[1000]; int i, counted=0;
#endif
calls=a->calls;
while(calls!=NULL) {
if (calls->locals!=NULL) {
/* primeiro vou ver se já foi copiado */
for(i=0;i<counted;i+=2) {
if (backup[i]==calls->locals) {
calls->locals=backup[i+1];
break;
}
}
if (i==counted) { /* afinal ainda nao foi copiado: fazer copia em duas fases*/
Cell *c, *newvars, *oldvars; int nr;
oldvars=calls->locals;
nr=oldvars[-1];
newvars=request_memory_locals(nr,0);
calls->locals=newvars;
/* primeiro actualizo as variaveis */
for(i=0;i<nr;i++) {
c=&oldvars[i];
VAR_TRAIL[VAR_TRAIL_NR]=(Cell) c;
VAR_TRAIL_NR-=MEM_Going;
VAR_TRAIL[VAR_TRAIL_NR]=(Cell) *c;
VAR_TRAIL_NR-=MEM_Going;
if ((Cell *)*c==c) {
newvars[i]=(Cell) &newvars[i];
*c=newvars[i];
} else {
newvars[i]= (Cell) *c;
*c=(Cell) &newvars[i];
}
}
/* depois copio as estruturas */
for(i=0;i<nr;i++) {
newvars[i]=copy_structures(oldvars[i]);
}
#if !Fast_go
if (max<counted+2) {
max+=200;
backup=realloc(backup,max);
if (backup==NULL) abort_eam("No more memory... realloc in gc \n");
}
#else
if (counted>=998) abort_eam("No more memory... realloc in gc \n");
#endif
backup[counted]=oldvars;
backup[counted+1]=newvars;
counted+=2;
}
}
calls=calls->next;
}
#if !Fast_go
free(backup);
#endif
}
/* redo the process to the inner boxes */
{ struct status_and *calls;
calls=a->calls;
while(calls!=NULL) {
if (calls->call!=NULL) {
register struct OR_BOX *o;
register struct status_or *nr;
o=calls->call;
nr=o->alternatives;
while(nr!=NULL) {
replicate_local_variables(nr->alternative);
nr=nr->next;
}
}
calls=calls->next;
}
}
if (MEM_Going==1) {
for(i=OLD_VAR_TRAIL_NR;i>VAR_TRAIL_NR;i-=2) {
Cell *c;
c=(Cell *) VAR_TRAIL[i];
*c=(Cell) VAR_TRAIL[i-1];
}
} else {
for(i=OLD_VAR_TRAIL_NR;i<VAR_TRAIL_NR;i+=2) {
Cell *c;
c=(Cell *) VAR_TRAIL[i];
*c=(Cell) VAR_TRAIL[i+1];
}
}
VAR_TRAIL_NR=OLD_VAR_TRAIL_NR;
}
Cell copy_structures(Cell c)
{
Cell *NewC, *NewH;
Cell OldC,OldH;
OldC=deref((Cell) c);
if (isvar(OldC)) {
return(OldC);
}
if (isatom(OldC)) {
return(OldC);
}
OldH=(Cell) _H;
NewH=_H;
if (isappl(OldC)) {
int i,arity;
NewC=(Cell *) repappl(OldC);
arity = ((int) ArityOfFunctor((Functor) *NewC));
*NewH++=*NewC++;
_H+=arity+1;
for(i=0;i<arity ;i++) {
*NewH=copy_structures((Cell) NewC);
NewH++;
NewC++;
}
return(absappl(OldH));
}
/* else if (ispair(c)) { */
NewC=(Cell *) reppair(OldC);
_H+=2;
*NewH=copy_structures((Cell) NewC);
NewC++;
NewH++;
*NewH=copy_structures((Cell) NewC);
return(abspair(OldH));
}

574
BEAM/eamamasm.c Normal file
View File

@ -0,0 +1,574 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: abstract machine assembler *
*************************************************************************/
#ifdef BEAM
#include "Yap.h"
#include "compile.h"
#include "clause.h"
#include "eam.h"
#include "eamamasm.h"
#include <stdio.h>
#include <stdlib.h>
Cell *inst_code;
int pass=0;
Cell *labels[1000];
Cell *Code_Start;
Cell Area_Code[200000];
Cell area_code=0;
extern Int inst_am(int n);
void emit_inst(long int i);
void emit_par(long int i);
void emit_upar(Cell i);
Cell *get_addr(void);
int Is_X_Var(Ventry *ve);
int Is_P_Var(Ventry *ve);
int X_Var(Ventry *ve);
int Y_Var(Ventry *ve);
void eam_pass(CInstr *ppc);
Cell *eam_assemble(CInstr *code);
int next_not_nop_inst(CInstr *ppc);
extern void *alloc_mem(Cell);
void emit_inst(long int i)
{
if (pass) *inst_code=inst_am(i);
inst_code++;
}
void emit_par(long int i)
{
if (pass) *inst_code=i;
inst_code++;
}
void emit_upar(Cell i)
{
if (pass) *inst_code=i;
inst_code++;
}
Cell *get_addr(void)
{
return(inst_code);
}
int Is_P_Var(Ventry *ve)
{
if (ve->FirstOfVE>0) return (1); /* var aparece pela primeira no corpo da clausula */
return(0);
}
int Is_X_Var(Ventry *ve)
{
if (ve->KindOfVE == PermVar) return(0);
if (ve->KindOfVE == VoidVar) return(0);
return(1);
}
int X_Var(Ventry *ve)
{
int var;
if (ve->KindOfVE == PermVar || ve->KindOfVE == VoidVar ) {
printf("Erro no tipo de variavel X ->eamamas.c \n");
exit(1);
}
var = ((ve->NoOfVE) & MaskVarAdrs);
return (var);
}
extern int nperm;
int Y_Var(Ventry *ve)
{
int var;
if (ve->KindOfVE != PermVar) {
printf("Erro no tipo de variavel Y ->eamamas.c \n");
exit(1);
}
var = ((ve->NoOfVE) & MaskVarAdrs);
return (var);
}
int next_not_nop_inst(CInstr *ppc) {
while(ppc) {
if ((int) ppc->op!=nop_op) return ((int) ppc->op);
ppc = ppc->nextInst;
}
return exit_op;
}
void eam_pass(CInstr *ppc)
{
int alloc_found=0;
int body=0;
while (ppc) {
switch ((int) ppc->op) {
case get_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_val_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_get_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_get_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case get_num_op:
case get_atom_op:
emit_inst(_get_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case get_list_op:
emit_inst(_get_list_op);
emit_par(ppc->new1);
break;
case get_struct_op:
emit_inst(_get_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor ) ppc->new4));
break;
case unify_last_local_op:
case unify_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case unify_last_val_op:
case unify_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_var_op:
case unify_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_unify_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_unify_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else { emit_inst(_unify_void_op); }
break;
case unify_last_atom_op:
case unify_last_num_op:
emit_inst(_unify_last_atom_op);
emit_par(ppc->new4);
break;
case unify_num_op:
case unify_atom_op:
emit_inst(_unify_atom_op);
emit_par(ppc->new4);
break;
case unify_list_op:
emit_inst(_unify_list_op);
break;
case unify_last_list_op:
emit_inst(_unify_last_list_op);
break;
case unify_struct_op:
emit_inst(_unify_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case unify_last_struct_op:
emit_inst(_unify_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case put_var_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_var_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_put_var_P_op);
else emit_inst(_put_var_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case put_val_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_put_val_X_op);
emit_par(ppc->new1);
emit_par(X_Var((Ventry *) ppc->new4));
break;
} else { /* else put_val_Y */
emit_inst(_put_val_Y_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
}
case put_unsafe_op:
emit_inst(_put_unsafe_op);
emit_par(ppc->new1);
emit_par(Y_Var((Ventry *) ppc->new4));
break;
case put_num_op:
case put_atom_op:
emit_inst(_put_atom_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case put_list_op:
emit_inst(_put_list_op);
emit_par(ppc->new1);
break;
case put_struct_op:
emit_inst(_put_struct_op);
emit_par(ppc->new1);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_var_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_var_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
if (Is_P_Var((Ventry *) ppc->new4)) emit_inst(_write_var_P_op);
else emit_inst(_write_var_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_local_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_local_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_local_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case write_val_op:
if (((Ventry *)(ppc->new4))->KindOfVE!=VoidVar) {
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_write_val_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_write_val_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
} else emit_inst(_write_void);
break;
case write_num_op:
case write_atom_op:
emit_inst(_write_atom_op);
emit_par(ppc->new4);
break;
case write_list_op:
emit_inst(_write_list_op);
break;
case write_last_list_op:
emit_inst(_write_last_list_op);
break;
case write_struct_op:
emit_inst(_write_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case write_last_struct_op:
emit_inst(_write_last_struct_op);
emit_par(ppc->new4);
emit_par(ArityOfFunctor((Functor )ppc->new4));
break;
case fail_op:
emit_inst(_fail_op);
break;
case cutexit_op:
printf("cutexit \n");
exit(1);
break;
case cut_op:
emit_inst(_cut_op);
break;
case commit_op:
emit_inst(_commit_op);
break;
case procceed_op:
emit_inst(_proceed_op);
break;
case pop_op:
emit_inst(_pop_op);
emit_par(ppc->new4);
break;
case save_b_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_b_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_b_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_pair_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_pair_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_pair_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case save_appl_op:
if (Is_X_Var((Ventry *) ppc->new4)) {
emit_inst(_save_appl_X_op);
emit_par(X_Var((Ventry *) ppc->new4));
} else {
emit_inst(_save_appl_Y_op);
emit_par(Y_Var((Ventry *) ppc->new4));
}
break;
case std_base_op:
emit_inst(_std_base+ppc->new4);
break;
case safe_call_op:
if (ppc->new1==1) {
emit_inst(_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_safe_call_binary_op);
} else {
emit_inst(_safe_call_op);
}
emit_par(ppc->new4);
break;
case direct_safe_call_op:
if (ppc->new1==1) {
emit_inst(_direct_safe_call_unary_op);
} else if (ppc->new1==2) {
emit_inst(_direct_safe_call_binary_op);
} else {
emit_inst(_direct_safe_call_op);
}
emit_par(ppc->new4);
break;
case call_op:
emit_inst(_call_op);
emit_par(ppc->new4);
break;
case skip_while_var_op:
emit_inst(_skip_while_var);
break;
case wait_while_var_op:
emit_inst(_wait_while_var);
break;
case force_wait_op:
emit_inst(_force_wait);
break;
case write_op:
if (ppc->new1=='\n') {
static Atom a=NULL;
if (a==NULL) a=Yap_LookupAtom("\n");
emit_inst(_put_atom_op);
emit_par(1);
emit_par((Cell) MkAtomTerm(a));
}
emit_inst(_write_call);
break;
case is_op:
emit_inst(_is_call);
break;
case equal_op:
emit_inst(_equal_call);
break;
case either_op:
emit_inst(_either_op);
emit_par(ppc->new1);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orelse_op:
emit_inst(_orelse_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case orlast_op:
emit_inst(_orlast_op);
break;
case create_first_box_op:
case create_box_op:
case create_last_box_op:
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
alloc_found=1;
break;
case remove_box_op:
case remove_last_box_op:
break;
case jump_op:
emit_inst(_jump_op);
emit_upar((Cell) Code_Start+ (Cell) labels[ppc->new4]);
break;
case label_op:
if (pass==0) labels[ppc->new4] = get_addr();
break;
case only_1_clause_op:
emit_inst(_only_1_clause_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case try_me_op:
emit_inst(_try_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(0); /* Nr da alternativa */
break;
case retry_me_op:
emit_inst(_retry_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case trust_me_op:
emit_inst(_trust_me_op);
emit_par(ppc->new4);
emit_par(((struct Clauses *)ppc->new4)->predi->arity);
emit_par(((struct Clauses *)ppc->new4)->nr_vars);
emit_par(ppc->new1);
break;
case body_op:
if (next_not_nop_inst(ppc->nextInst)==procceed_op) {
//emit_inst(_proceed_op);
break;
} else if (next_not_nop_inst(ppc->nextInst)==fail_op) {
//emit_inst(_fail_op);
break;
}
if (ppc->new4!=0) {
emit_inst(_prepare_calls);
emit_par(ppc->new4); /* nr_calls */
}
body=1;
break;
case prepare_tries:
emit_inst(_prepare_tries);
emit_par(ppc->new1);
emit_par(ppc->new4);
break;
case exit_op:
emit_inst(_exit_eam);
break;
case mark_initialised_pvars_op:
break;
case fetch_args_for_bccall:
case bccall_op:
printf("[ Fatal Error: fetch and bccall instructions not supported ]\n");
exit(1);
break;
case endgoal_op:
case nop_op:
case name_op:
break;
default:
if (pass) {
printf("[ Sorry, there is at least one unsupported instruction in your code... %3d] %d\n",ppc->op,exit_op);
printf("[ please note that beam still does not support a lot of builtins ]\n");
}
emit_inst(_fail_op);
}
ppc = ppc->nextInst;
}
emit_inst(_exit_eam);
emit_par(-1);
}
Cell *eam_assemble(CInstr *code)
{
Code_Start=0;
pass=0;
inst_code=0;
eam_pass(code);
pass=1;
Code_Start=alloc_mem((Cell) inst_code);
inst_code=Code_Start;
eam_pass(code);
return(Code_Start);
}
#endif /* BEAM */

129
BEAM/eamamasm.h Normal file
View File

@ -0,0 +1,129 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: abstract machine instructions *
*************************************************************************/
#define _exit_eam 0
#define _top_tree 1
#define _scheduler 2
#define _prepare_tries 3
#define _prepare_calls 4
#define _first_get _prepare_calls
#define _get_var_X_op _first_get+1
#define _get_var_Y_op _first_get+2
#define _get_val_X_op _first_get+3
#define _get_val_Y_op _first_get+4
#define _get_atom_op _first_get+5
#define _get_list_op _first_get+6
#define _get_struct_op _first_get+7
#define _first_unify _get_struct_op
#define _unify_void_op _first_unify + 1
#define _unify_val_X_op _first_unify + 2
#define _unify_val_Y_op _first_unify + 3
#define _unify_var_X_op _first_unify + 4
#define _unify_var_Y_op _first_unify + 5
#define _unify_atom_op _first_unify + 6
#define _unify_list_op _first_unify + 7
#define _unify_last_list_op _first_unify + 8
#define _unify_struct_op _first_unify + 9
#define _unify_last_struct_op _first_unify + 10
#define _unify_last_atom_op _first_unify + 11
#define _unify_local_X_op _first_unify + 12
#define _unify_local_Y_op _first_unify + 13
#define _first_put _unify_local_Y_op
#define _put_var_X_op _first_put + 1
#define _put_var_Y_op _first_put + 2
#define _put_val_X_op _first_put + 3
#define _put_val_Y_op _first_put + 4
#define _put_atom_op _first_put + 5
#define _put_list_op _first_put + 6
#define _put_struct_op _first_put + 7
#define _put_unsafe_op _first_put + 8
#define _put_var_P_op _first_put + 9
#define _first_write _put_var_P_op
#define _write_void _first_write + 1
#define _write_var_X_op _first_write + 2
#define _write_var_Y_op _first_write + 3
#define _write_val_X_op _first_write + 4
#define _write_val_Y_op _first_write + 5
#define _write_atom_op _first_write + 6
#define _write_list_op _first_write + 7
#define _write_struct_op _first_write + 8
#define _write_last_list_op _first_write + 9
#define _write_last_struct_op _first_write + 10
#define _write_local_X_op _first_write + 11
#define _write_local_Y_op _first_write + 12
#define _write_var_P_op _first_write + 13
#define _geral _write_var_P_op
#define _pop_op _geral + 1
#define _jump_op _geral + 2
#define _proceed_op _geral + 3
#define _call_op _geral + 4
#define _safe_call_op _geral + 5
#define _safe_call_unary_op _geral + 6
#define _safe_call_binary_op _geral + 7
#define _only_1_clause_op _geral + 8
#define _try_me_op _geral + 9
#define _retry_me_op _geral + 10
#define _trust_me_op _geral + 11
#define _do_nothing_op _geral + 12
#define _direct_safe_call_op _geral + 13
#define _direct_safe_call_unary_op _geral + 14
#define _direct_safe_call_binary_op _geral + 15
#define _skip_while_var _geral + 16
#define _wait_while_var _geral + 17
#define _force_wait _geral + 18
#define _write_call _geral + 19
#define _is_call _geral + 20
#define _equal_call _geral + 21
#define _cut_op _geral + 22
#define _commit_op _geral + 23
#define _fail_op _geral + 24
#define _others _fail_op
#define _save_b_X_op _others + 1
#define _save_b_Y_op _others + 2
#define _comit_b_X_op _others + 3
#define _comit_b_Y_op _others + 4
#define _save_appl_X_op _others + 5
#define _save_appl_Y_op _others + 6
#define _save_pair_X_op _others + 7
#define _save_pair_Y_op _others + 8
#define _either_op _others + 9
#define _orelse_op _others + 10
#define _orlast_op _others + 11
#define _std_base _orlast_op
#define _p_atom (_std_base+1)
#define _p_atomic (_std_base+2)
#define _p_equal (_std_base+3)
#define _p_integer (_std_base+4)
#define _p_nonvar (_std_base+5)
#define _p_number (_std_base+6)
#define _p_var (_std_base+7)
#define _p_db_ref (_std_base+8)
#define _p_primitive (_std_base+9)
#define _p_cut_by (_std_base+10)
#define _p_succ (_std_base+11)
#define _p_predc (_std_base+12)
#define _p_plus (_std_base+13)
#define _p_minus (_std_base+14)
#define _p_times (_std_base+15)
#define _p_div (_std_base+16)
#define _p_dif (_std_base+17)
#define _p_eq (_std_base+18)
#define _p_arg (_std_base+19)
#define _p_functor (_std_base+20)

319
BEAM/eamindex.c Normal file
View File

@ -0,0 +1,319 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: indexing related functions *
*************************************************************************/
#ifdef BEAM
#include "Yap.h"
#include "compile.h"
#include "clause.h"
#include "eam.h"
#include <stdio.h>
#include <stdlib.h>
CInstr *StartCode,*inter_code;
extern void eam_showcode(Cell *code);
extern unsigned int index_of_hash_table_atom(Cell c, int nr);
extern unsigned int index_of_hash_table_appl(Cell c, int nr);
extern CInstr *emit_new(int o, int r1,CELL r4);
Cell *gera_codigo_try(struct Predicates *);
Cell *gera_codigo_try_list(struct Predicates *predi);
Cell *gera_codigo_try_only_vars(struct Predicates *predi);
struct HASH_TABLE **gera_codigo_try_atom(struct Predicates *predi);
struct HASH_TABLE **gera_codigo_try_functor(struct Predicates *predi);
extern Cell *eam_assemble(CInstr *code);
void do_eam_indexing(struct Predicates *p);
void ver_predicados(struct Predicates *p);
int exists_on_table(Cell a,struct HASH_TABLE **table, int i);
int exists_on_table(Cell a,struct HASH_TABLE **table, int i)
{
struct HASH_TABLE *t;
t=table[i];
while(t) {
if (t->value==a) return(1);
t=t->next;
}
return(0);
}
Cell *gera_codigo_try(struct Predicates *predi) /* gerar os try's para o predicado i */
{
struct Clauses *c;
int nr=0;
StartCode=NULL;
inter_code=NULL;
c=predi->first;
emit_new(prepare_tries,predi->nr_alt,predi->arity);
if (predi->nr_alt==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
} else if (predi->nr_alt>1) {
while(c!=NULL) {
if (nr+1==predi->nr_alt) emit_new(trust_me_op,nr,(unsigned long) c);
else if (nr==0) emit_new(try_me_op,predi->nr_alt,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
c=c->next;
nr++;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
Cell *gera_codigo_try_list(struct Predicates *predi) /* gerar os try's para o predicado i */
{
struct Clauses *c;
int nr=0,nr_preds;
StartCode=NULL;
inter_code=NULL;
nr_preds=predi->idx_list+predi->idx_var;
c=predi->first;
emit_new(prepare_tries,nr_preds,predi->arity);
if (nr_preds>=1) {
while(c!=NULL) {
if (c->predi==predi && (c->idx==Lista || c->idx==Variavel)) {
if (nr_preds==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
break;
}
if (nr+1==nr_preds) { emit_new(trust_me_op,nr,(unsigned long) c); break; }
else if (nr==0) emit_new(try_me_op,nr_preds,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
nr++;
}
c=c->next;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
struct HASH_TABLE **gera_codigo_try_atom(struct Predicates *predi)
{
int j,nr_preds,nr_atoms;
struct HASH_TABLE **table;
struct HASH_TABLE *t;
struct Clauses *cla;
nr_atoms=predi->idx_atom;
nr_preds=nr_atoms+predi->idx_var;
table=malloc(sizeof(struct HASH_TABLE *)*(nr_atoms+1));
for (j=0;j<=nr_atoms;j++) table[j]=NULL;
cla=predi->first;
while(cla) {
if (cla->idx==Constante) {
Cell a;
unsigned int index;
int nr;
a=cla->val;
if (a && nr_atoms) {
index=index_of_hash_table_atom(a,nr_atoms);
} else index=nr_atoms;
/* printf("nr_atoms=%d index=%d -> 0x%X \n",nr_atoms,index,a); */
if (!exists_on_table(a,table,index)) {
CInstr *first,*last=NULL,*prepare;
struct Clauses *cla2;
/* printf("a gerar codigo para atom index=%d value %ld\n",index,cla->val); */
t=malloc(sizeof(struct HASH_TABLE));
t->next=table[index];
table[index]=t;
t->value=a;
StartCode=NULL;
inter_code=NULL;
prepare=emit_new(prepare_tries,0,predi->arity);
cla2=predi->first;
nr=0;
first=NULL;
while(cla2) {
if ((cla2->idx==Constante && cla2->val==a) || cla2->idx==Variavel) {
last=emit_new(retry_me_op,nr,(unsigned long) cla2);
if (first==NULL) first=last;
nr++;
}
cla2=cla2->next;
}
prepare->new1=nr;
if (first==last) {
first->op=only_1_clause_op;
} else {
first->op=try_me_op;
last->op=trust_me_op;
}
t->code=eam_assemble(StartCode);
}
}
cla=cla->next;
}
return(table);
}
struct HASH_TABLE **gera_codigo_try_functor(struct Predicates *predi) /*gerar os try's para o predicado i*/
{
int j,nr_preds,nr_appls;
struct HASH_TABLE **table;
struct HASH_TABLE *t;
struct Clauses *cla;
nr_appls=predi->idx_functor;
nr_preds=nr_appls+predi->idx_var;
table=malloc(sizeof(struct HASH_TABLE *)*(nr_appls+1));
for (j=0;j<=nr_appls;j++) table[j]=NULL;
cla=predi->first;
while(cla) {
if (cla->idx==Estrutura) {
Cell a;
long int index;
int nr;
a=cla->val;
if (a && nr_appls) {
index=index_of_hash_table_appl(a,nr_appls);
} else index=nr_appls;
if (!exists_on_table(a,table,index)) {
CInstr *first,*last=NULL,*prepare;
struct Clauses *cla2;
/* printf("a gerar codigo para appl index=%d value %ld\n",index,cla->val); */
t=malloc(sizeof(struct HASH_TABLE));
t->next=table[index];
table[index]=t;
t->value=a;
StartCode=NULL;
inter_code=NULL;
prepare=emit_new(prepare_tries,0,predi->arity);
cla2=predi->first;
nr=0;
first=NULL;
while(cla2) {
if ((cla2->idx==Estrutura && cla2->val==a) || cla2->idx==Variavel) {
last=emit_new(retry_me_op,nr,(unsigned long) cla2);
if (first==NULL) first=last;
nr++;
}
cla2=cla2->next;
}
prepare->new1=nr;
if (first==last) {
first->op=only_1_clause_op;
} else {
first->op=try_me_op;
last->op=trust_me_op;
}
t->code=eam_assemble(StartCode);
}
}
cla=cla->next;
}
return(table);
}
Cell *gera_codigo_try_only_vars(struct Predicates *predi) /* gerar os try's de Vars para o predicado i */
{
struct Clauses *c;
int nr=0,nr_preds;
StartCode=NULL;
inter_code=NULL;
nr_preds=predi->idx_var;
c=predi->first;
emit_new(prepare_tries,nr_preds,predi->arity);
if (nr_preds>=1) {
while(c!=NULL) {
if (c->predi==predi && c->idx==Variavel) {
if (nr_preds==1) {
emit_new(only_1_clause_op,0,(unsigned long) c);
break;
}
if (nr+1==nr_preds) { emit_new(trust_me_op,nr,(unsigned long) c); break; }
else if (nr==0) emit_new(try_me_op,nr_preds,(unsigned long) c);
else emit_new(retry_me_op,nr,(unsigned long) c);
nr++;
}
c=c->next;
}
} else {
emit_new(fail_op,0,0);
}
return(eam_assemble(StartCode));
}
void do_eam_indexing(struct Predicates *p)
{
p->code=gera_codigo_try(p);
p->idx=-1;
if (p->arity && (p->idx_list || p->idx_atom || p->idx_functor)) {
p->vars=gera_codigo_try_only_vars(p);
p->list=gera_codigo_try_list(p);
p->functor=gera_codigo_try_functor(p);
p->atom=gera_codigo_try_atom(p);
p->idx=1;
}
if((Print_Code & 4) && (Print_Code & 8)) {
printf("General Case :\n");
eam_showcode(p->code);
}
if (Print_Code & 1) ver_predicados(p);
}
void ver_predicados(struct Predicates *p)
{
struct Clauses *c; int i=0;
printf("Predicado %s:%d (ES=%d) tem %d clausulas do tipo V=%d L=%d A=%d F=%d \n",p->name,p->arity,p->eager_split,p->nr_alt,p->idx_var,p->idx_list,p->idx_atom,p->idx_functor);
c=p->first;
while(c!=NULL) {
printf("Clausula %d do tipo %d (%d locals %d args) (val=0x%X)\n",++i,c->idx,c->nr_vars,c->predi->arity, (unsigned )c->val);
c=c->next;
}
}
#endif /* BEAM */

763
BEAM/toeam.c Normal file
View File

@ -0,0 +1,763 @@
/*************************************************************************
* *
* BEAM -> Basic Extended Andorra Model *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright: Ricardo Lopes and NCC - University of Porto, Portugal *
* *
**************************************************************************
* comments: eam code compiler *
*************************************************************************/
#ifdef BEAM
#include "eam.h"
#include "eamamasm.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
extern int skip_while_var(void);
extern int wait_while_var(void);
extern int force_wait(void);
extern int p_write(void);
extern int p_is(void);
extern int p_halt(void);
extern int p_halt0(void);
extern int commit(void);
extern int eager_split(void);
extern void eam_showcode(Cell *);
extern Cell *eam_assemble(CInstr *);
extern void ShowCode_new2(int, int, CELL);
extern Cell *gera_codigo_try(int);
extern Cell *gera_codigo_try_list(int);
extern Cell *gera_codigo_try_only_vars(int);
extern struct HASH_TABLE **gera_codigo_try_atom(int);
extern struct HASH_TABLE **gera_codigo_try_functor(int);
/* Novas Definicoes */
compiler_struct *CGLOBS;
int labelno;
extern int nperm;
CInstr *inter_code,*StartCode;
void convert_Yaam(struct Clauses *);
void anota_predicados(struct Clauses *, PredEntry *,unsigned long ,int ,int ,int);
void verifica_predicados(struct Clauses *);
void ShowCode_new(int);
void codigo_eam(compiler_struct *);
void ver_predicados(void);
void eam_instructions(struct Clauses *);
void identify_calls(CInstr *);
int needs_box(Cell);
int is_skip(Cell);
void delay_prepare_calls(void);
int test_for_side_effects(void);
CInstr *insert_inst(CInstr *, int,int,CELL);
CInstr *emit_new(int, int, CELL);
CInstr *new_inst(int, int, CELL);
void *alloc_mem_temp(Cell);
void *alloc_mem(Cell);
/***********************************************************************\
* Aqui estao as novas partes do compilador *
\***********************************************************************/
void anota_predicados(struct Clauses *clause, PredEntry *p, unsigned long a,int b,int info_type,int call)
{
struct Predicates *predi;
if (p->beamTable==NULL) { /*1 vez que aparece, inicializar uma nova estrutura */
predi=(struct Predicates *) alloc_mem(sizeof(struct Predicates));
p->beamTable=predi;
predi->id=a;
predi->name=(char *) RepAtom(AtomOfTerm(MkAtomTerm((Atom) a)))->StrOfAE;
predi->arity=b;
predi->nr_alt=0;
predi->calls=0;
predi->idx_var=0;
predi->idx_list=0;
predi->idx_atom=0;
predi->idx_functor=0;
predi->first=NULL;
predi->last=NULL;
} else predi=p->beamTable;
if (!call) { /* se nao foi chamado por um call, entao anota informacao */
predi->id=a;
predi->nr_alt++;
if (info_type & Variavel ) predi->idx_var++; /* info_type=Lista+Estrutura+Constante; */
if (info_type & Lista ) predi->idx_list++;
if (info_type & Estrutura) predi->idx_functor++;
if (info_type & Constante) predi->idx_atom++;
if (predi->last==NULL) {
predi->first=clause;
predi->last=clause;
clause->next=NULL;
} else {
predi->last->next=clause;
predi->last=clause;
clause->next=NULL;
}
}
return;
}
void identify_calls(CInstr *code) {
PredEntry *p = RepPredProp((Prop) code->new4);
Functor f = p->FunctorOfPred;
int arity=p->ArityOfPE;
char *name;
if ( arity == 0) name=((AtomEntry *) f)->StrOfAE;
else name=((AtomEntry *) NameOfFunctor(f))->StrOfAE;
/*
if (code->op==call_op) printf("call: ");
else if (code->op==safe_call_op) printf("call: ");
else if (code->op==execute_op) printf("execute: ");
printf("->%s/%d...............\n",name,arity);
*/
if (arity==0) {
if (strcmp(name,"/")==0) { code->op=commit_op; return; }
if (strcmp(name,":")==0) { code->op=force_wait_op; return; }
if (strcmp(name,"nl")==0) { code->op=write_op; code->new1='\n'; return; }
if (strcmp(name,"halt")==0) { code->op=exit_op; return; }
} else if (arity==1) {
if (strcmp(name,"wait_while_var")==0) { code->op=wait_while_var_op; return; }
if (strcmp(name,"skip_while_var")==0) { code->op=skip_while_var_op; return; }
if (strcmp(name,"write")==0) { code->op=write_op; return; }
} else if (arity==2) {
if (strcmp(name,"is")==0) { code->op=is_op; return; }
}
/* não é nenhum call conhecido, deve ser um predicado em Prolog */
return;
}
/* no verifica_predicados, vou transformar os calls para */
void verifica_predicados(struct Clauses *clause)
{
CELL Flags;
inter_code=StartCode;
anota_predicados(clause,(CGLOBS->cint).CurrentPred, StartCode->new4,StartCode->new1,clause->idx,0);
while(inter_code!=NULL) {
if (inter_code->op==safe_call_op) { /* new1 deve continuar igual */
Flags = RepPredProp((Prop) (inter_code->new4))->PredFlags;
if (Flags & AsmPredFlag) {
inter_code->op=std_base_op;
inter_code->new4=(Flags &0x7f);
} else {
PredEntry *p=RepPredProp((Prop) inter_code->new4);
inter_code->op=safe_call_op;
inter_code->new4= (unsigned long) p->cs.f_code;
if (Flags & BinaryTestPredFlag) inter_code->new1=2;
else inter_code->new1=0;
}
}
else if (inter_code->op==call_op || inter_code->op==execute_op) {
PredEntry *p = RepPredProp((Prop) inter_code->new4);
Flags = p->PredFlags;
Functor f = p->FunctorOfPred;
if (Flags & AsmPredFlag) {
int op;
switch (Flags & 0x7f) {
case _equal:
op = _p_equal;
break;
case _dif:
op = _p_dif;
break;
case _eq:
op = _p_eq;
break;
case _arg:
op = _p_arg;
break;
case _functor:
op = _p_functor;
break;
default:
printf("Internal eam assembler error for built-in %d\n",((int) (Flags & 0x7f)));
exit(1);
}
}
if (!(Flags & CPredFlag)) {
if (p->ArityOfPE == 0) f = Yap_MkFunctor((Atom) f, 0);
inter_code->new4=(unsigned long) p;
anota_predicados(clause, p, (unsigned long) NameOfFunctor(f),ArityOfFunctor(f),0,1);
p->beamTable->calls++;
} else {/* safe_call */
inter_code->op=safe_call_op;
inter_code->new4= (unsigned long) p->cs.f_code;
if (Flags & BinaryTestPredFlag) inter_code->new1=2;
else inter_code->new1=0;
}
}
inter_code=inter_code->nextInst;
}
return;
}
void ShowCode_new(int i)
{
/*
struct intermediates c;
c.CodeStart=StartCode;
Yap_ShowCode(&c);
return;
*/
#ifdef DEBUG
switch(i) {
case 1: printf("\nVer Predicados \n");
break;
case 2: printf("\nVer yaam Original\n");
break;
case 4: printf("\nVer abs machine code\n");
break;
case 8: printf("\nVer o codigo dos trys\n");
break;
case 16: printf("\nVer o codigo yaam ja transformado\n");
break;
case 32: printf("\nver codigo EAM com direct calls\n");
break;
case 128: printf("\nVer codigo EAM final\n");
break;
}
inter_code = StartCode;
while (inter_code) {
ShowCode_new2(inter_code->op, inter_code->new1,inter_code->new4);
inter_code = inter_code->nextInst;
}
printf("\n");
#endif
}
void codigo_eam(compiler_struct *cglobs)
{
struct Clauses *clause;
CGLOBS=cglobs;
labelno=cglobs->labelno;
#ifdef DEBUG
if (Print_Code & 2 ) Yap_ShowCode(&CGLOBS->cint);
#endif
clause=(struct Clauses *) alloc_mem(sizeof(struct Clauses));
convert_Yaam(clause); /* convert into an internal struct code and check IDX */
verifica_predicados(clause); /* check predicates and convert calls */
clause->predi=(CGLOBS->cint).CurrentPred->beamTable;
(CGLOBS->cint).CurrentPred->beamTable->idx=0; /* will need to go by indexing */
if (Print_Code & 4) ShowCode_new(2); /* codigo YAAM */
/* transf os safe_calls em instrucoes eam e verifica se existem side_effects */
clause->side_effects=test_for_side_effects();
eam_instructions(clause);
if (Print_Code & 16) ShowCode_new(16); /* codigo EAM */
inter_code=NULL;
delay_prepare_calls(); /* transforma alguns safe_calls em direct_calls */
if (Print_Code & 32) ShowCode_new(32); /* codigo com direct_callss */
clause->code=eam_assemble(StartCode);
clause->nr_vars=nperm;
if (Print_Code & 128) eam_showcode((Cell *)clause->code);
}
/********************************************************\
* Convert Code *
\********************************************************/
int is_skip(Cell op)
{
if (op==skip_while_var_op) return(1);
if (op==wait_while_var_op) return(1);
return(0);
}
void eam_instructions(struct Clauses *clause)
{
int calls=0,nr_call=0;
CInstr *b_code=NULL;
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) calls=0;
if (inter_code->op==procceed_op) inter_code->nextInst=NULL; /* CUIDADO */
if (inter_code->op==allocate_op) inter_code->op=nop_op;
if (inter_code->op==deallocate_op) inter_code->op=nop_op;
if (inter_code->op==cutexit_op) {
inter_code->op=cut_op;
insert_inst(inter_code,procceed_op,0,0);
}
if (inter_code->op==fail_op) insert_inst(inter_code,procceed_op,0,0);
if (inter_code->op==execute_op) {
inter_code->op=call_op;
insert_inst(inter_code,procceed_op,0,0);
}
if (inter_code->op==safe_call_op) {
if ((void *)inter_code->new4==(void *) eager_split) {
inter_code->op=nop_op;
clause->predi->eager_split=1;
}
}
if (needs_box(inter_code->op)) calls++;
inter_code=inter_code->nextInst;
}
if (calls) {
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) {
inter_code->new4=calls;
insert_inst(inter_code,create_first_box_op,calls,++labelno);
inter_code=inter_code->nextInst;
}
if (needs_box(inter_code->op)) {
insert_inst(inter_code,remove_box_op,nr_call,0);
inter_code=inter_code->nextInst;
b_code=inter_code;
insert_inst(inter_code,label_op,nr_call,labelno);
inter_code=inter_code->nextInst;
insert_inst(inter_code,create_box_op,++nr_call,++labelno);
}
inter_code=inter_code->nextInst;
}
b_code->op=remove_last_box_op;
b_code->nextInst->nextInst->op=nop_op;
}
}
void delay_prepare_calls(void) {
CInstr *b_code=NULL;
inter_code=StartCode;
while(inter_code!=NULL){
if (inter_code->op==body_op) b_code=inter_code;
if (inter_code->op!=safe_call_op && inter_code->op!=cut_op && (needs_box(inter_code->op) || is_skip(inter_code->op))) break;
if (inter_code->op==safe_call_op) {
inter_code->op=direct_safe_call_op;
b_code->nextInst->op=nop_op;
inter_code->nextInst->op=nop_op;
if (b_code->new4>1) {
inter_code->nextInst->nextInst->op=body_op;
inter_code->nextInst->nextInst->new1=0;
inter_code->nextInst->nextInst->new4=b_code->new4-1;
} else {
inter_code->nextInst->nextInst->op=procceed_op;
inter_code->nextInst->nextInst->new1=0;
inter_code->nextInst->nextInst->new4=0;
}
b_code->op=nop_op;
}
inter_code=inter_code->nextInst;
}
}
int needs_box(Cell op)
{
if (op==safe_call_op) return(1);
if (op==call_op) return(1);
if (op==std_base_op) return(1);
if (op==fail_op) return(1);
if (op==force_wait_op) return(1);
if (op==cut_op) return(1);
if (op==commit_op) return(1);
if (op==cutexit_op) return(1);
if (op==write_op) return(1);
if (op==is_op) return(1);
if (op==equal_op) return(1);
if (op==exit_op) return(1);
return(0);
}
int test_for_side_effects()
{
int side_effects=0;
inter_code=StartCode;
while(inter_code!=NULL){
switch (inter_code->op) {
case write_op:
side_effects+=WRITE;
break;
case cutexit_op:
case commit_op:
case cut_op:
side_effects+=CUT;
break;
case force_wait_op:
side_effects+=SEQUENCIAL;
break;
}
inter_code=inter_code->nextInst;
}
return(side_effects);
}
void convert_Yaam(struct Clauses *clause)
{
PInstr *CodeStart, *ppc;
int calls=0;
clause->val=0;
clause->idx=Variavel;
StartCode=NULL;
inter_code=NULL;
CodeStart=(&CGLOBS->cint)->CodeStart;
ppc=CodeStart;
while(ppc!=NULL){ /* copia o codigo YAAM para poder ser alterado e ve o tipo de indexacao*/
if (ppc->op!=nop_op) {
if (ppc->op==get_var_op && ppc->rnd2==1) { clause->idx=Variavel; clause->val=0; }
if (ppc->op==get_list_op && ppc->rnd2==1) { clause->idx=Lista; clause->val=0; }
if (ppc->op==get_struct_op && ppc->rnd2==1) { clause->idx=Estrutura; clause->val=ppc->rnd1; }
if ((ppc->op==get_atom_op || ppc->op==get_num_op) && ppc->rnd2==1) { clause->idx=Constante; clause->val=ppc->rnd1; }
if (ppc->op==body_op || ppc->op==safe_call_op || ppc->op==call_op || ppc->op==execute_op) calls=1;
if (ppc->op==endgoal_op) {
if (calls==0) emit_new(equal_op, 0, 0);
calls=0;
} else {
emit_new(ppc->op, ppc->rnd2, ppc->rnd1);
if (ppc->op==body_op) calls=1;
if (ppc->op==safe_call_op || ppc->op==call_op || ppc->op==execute_op) {
calls=1; identify_calls(inter_code);
}
}
}
ppc=ppc->nextInst;
}
emit_new(nop_op, 0,0);
emit_new(nop_op, 0,0);
CodeStart->nextInst=NULL;
ppc=CodeStart;
(&CGLOBS->cint)->cpc=CodeStart;
Yap_emit(cut_op,Zero,Zero,&CGLOBS->cint);
Yap_emit(run_op,Zero,(unsigned long) (CGLOBS->cint).CurrentPred,&CGLOBS->cint);
Yap_emit(procceed_op, Zero, Zero, &CGLOBS->cint);
return;
}
CInstr *insert_inst(CInstr *inst, int o,int r1,CELL r4)
{
CInstr *p;
p=new_inst(o,r1,r4);
if (inst==NULL) inst=p;
else {
p->nextInst=inst->nextInst;
inst->nextInst=p;
}
return (p);
}
CInstr *emit_new(int o, int r1,CELL r4)
{
CInstr *p;
p=new_inst(o,r1,r4);
if (inter_code == NULL) {
inter_code = StartCode = p;
}
else {
inter_code->nextInst = p;
inter_code = p;
}
return(inter_code);
}
CInstr *new_inst(int o, int r1,CELL r4)
{
CInstr *p;
p = (CInstr *) alloc_mem_temp(sizeof(CInstr));
p->op = o;
p->new1 = r1;
p->new4 = r4;
p->nextInst = NULL;
return(p);
}
void *alloc_mem(Cell size)
{
void *p;
p=malloc(size);
if (p==NULL) { printf(" Erro, falta de memoria \n"); exit(1); }
// p=Yap_AllocCMem(size,&CGLOBS->cint);
return(p);
}
void *alloc_mem_temp(Cell size) /* memory that will be discard after compiling */
{
void *p;
p=malloc(size);
if (p==NULL) { printf(" Erro, falta de memoria \n"); exit(1); }
// p=Yap_AllocCMem(size,&CGLOBS->cint);
return(p);
}
#ifdef DEBUG
static char *opformat2[] =
{
"nop",
"get_var %1,%4",
"put_var %1,%4",
"get_val %1,%4",
"put_val %1,%4",
"get_atom %1,%4",
"put_atom %1,%4",
"get_num %1,%4",
"put_num %1,%4",
"get_float %1,%4",
"put_float %1,%4",
"align_float %1,%4",
"get_longint %1,%4",
"put_longint %1,%4",
"get_bigint %1,%4",
"put_bigint %1,%4",
"get_list %1,%4",
"put_list %1,%4",
"get_struct %1,%4",
"put_struct %1,%4",
"put_unsafe %1,%4",
"unify_var %1,%4",
"write_var %1,%4",
"unify_val %1,%4",
"write_val %1,%4",
"unify_atom %1,%4",
"write_atom %1,%4",
"unify_num %1,%4",
"write_num %1,%4",
"unify_float %1,%4",
"write_float %1,%4",
"unify_longint %1,%4",
"write_longint %1,%4",
"unify_bigint %1,%4",
"write_bigint %1,%4",
"unify_list %1,%4",
"write_list %1,%4",
"unify_struct %1,%4",
"write_struct %1,%4",
"write_unsafe %1,%4",
"fail %1,%4",
"cut %1,%4",
"cutexit %1,%4",
"allocate %1,%4",
"deallocate %1,%4",
"try_me_else %1,%4",
"jump %1,%4",
"jump %1,%4",
"proceed %1,%4",
"call %1,%4",
"execute %1,%4",
"sys %1,%4",
"%l: %1,%4",
"name %1,%4",
"pop %1,%4",
"retry_me_else %1,%4",
"trust_me_else_fail %1,%4",
"either_me %1,%4",
"or_else %1,%4",
"or_last %1,%4",
"push_or %1,%4",
"pushpop_or %1,%4",
"pop_or %1,%4",
"save_by %1,%4",
"commit_by %1,%4",
"patch_by %1,%4",
"try %1,%4",
"retry %1,%4",
"trust %1,%4",
"try_in %1,%4",
"jump_if_var %1,%4",
"jump_if_nonvar %1,%4",
"cache_arg %1,%4",
"cache_sub_arg %1,%4",
"switch_on_type %1,%4",
"switch_on_constant %1,%4",
"if_constant %1,%4",
"switch_on_functor %1,%4",
"if_functor %1,%4",
"if_not_then %1,%4",
"index_on_dbref %1,%4",
"index_on_blob %1,%4",
"check_var %1,%4",
"save_pair %1,%4",
"save_appl %1,%4",
"fail_label %1,%4",
"unify_local %1,%4",
"write local %1,%4",
"unify_last_list %1,%4",
"write_last_list %1,%4",
"unify_last_struct %1,%4",
"write_last_struct %1,%4",
"unify_last_var %1,%4",
"unify_last_val %1,%4",
"unify_last_local %1,%4",
"unify_last_atom %1,%4",
"unify_last_num %1,%4",
"unify_last_float %1,%4",
"unify_last_longint %1,%4",
"unify_last_bigint %1,%4",
"pvar_bitmap %1,%4",
"pvar_live_regs %1,%4",
"fetch_reg1_reg2 %1,%4",
"fetch_constant_reg %1,%4",
"fetch_reg_constant %1,%4",
"function_to_var %1,%4",
"function_to_al %1,%4",
"enter_profiling %1,%4",
"retry_profiled %1,%4",
"count_call_op %1,%4",
"count_retry_op %1,%4",
"restore_temps %1,%4",
"restore_temps_and_skip %1,%4",
"enter_lu %1,%4",
"empty_call %1,%4",
#ifdef YAPOR
"sync
#endif /* YAPOR */
#ifdef TABLING
"table_new_answer %1,%4",
"table_try_single %1,%4",
#endif /* TABLING */
#ifdef TABLING_INNER_CUTS
"clause_with_cut %1,%4",
#endif /* TABLING_INNER_CUTS */
#ifdef BEAM
"run_op %1,%4",
"body_op %1",
"endgoal_op",
"try_me_op %1,%4",
"retry_me_op %1,%4",
"trust_me_op %1,%4",
"only_1_clause_op %1,%4",
"create_first_box_op %1,%4",
"create_box_op %1,%4",
"create_last_box_op %1,%4",
"remove_box_op %1,%4",
"remove_last_box_op %1,%4",
"prepare_tries",
"std_base_op %1,%4",
"direct_safe_call",
"commit_op",
"skip_while_var_op",
"wait_while_var_op",
"force_wait_op",
"write_op",
"is_op",
"exit",
#endif
"fetch_args_for_bccall %1,%4",
"binary_cfunc %1,%4",
"blob %1,%4",
#ifdef SFUNC
,
"get_s_f_op %1,%4",
"put_s_f_op %1,%4",
"unify_s_f_op %1,%4",
"write_s_f_op %1,%4",
"unify_s_var %1,%4",
"write_s_var %1,%4",
"unify_s_val %1,%4",
"write_s_val %1,%4",
"unify_s_a %1,%4",
"write_s_a %1,%4",
"get_s_end",
"put_s_end",
"unify_s_end",
"write_s_end"
#endif
};
void ShowCode_new2(int op, int new1,CELL new4);
void ShowCode_new2(int op, int new1,CELL new4)
{
char *f,ch;
f=opformat2[op];
while ((ch = *f++) != 0)
{
if (ch == '%')
switch (ch = *f++)
{
case '1':
Yap_plwrite(MkIntTerm(new1), Yap_DebugPutc, 0);
break;
case '4':
Yap_plwrite(MkIntTerm(new4), Yap_DebugPutc, 0);
break;
default:
Yap_DebugPutc (Yap_c_error_stream,'%');
Yap_DebugPutc (Yap_c_error_stream,ch);
}
else
Yap_DebugPutc (Yap_c_error_stream,ch);
}
Yap_DebugPutc (Yap_c_error_stream,'\n');
}
#endif
#endif /* BEAM */