This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
Vitor Santos Costa 51e669dcfb support for passing priority as argument to write. (Ulrich's ).
fixes on making write handle infinite loops
2009-05-22 13:24:27 -05:00

765 lines
19 KiB
C
Raw Blame History

/*************************************************************************
* *
* 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 <20> 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 & BinaryPredFlag) 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 & BinaryPredFlag) 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,nrcall=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,nrcall,0);
inter_code=inter_code->nextInst;
b_code=inter_code;
insert_inst(inter_code,label_op,nrcall,labelno);
inter_code=inter_code->nextInst;
insert_inst(inter_code,create_box_op,++nrcall,++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, 1200);
break;
case '4':
Yap_plwrite(MkIntTerm(new4), Yap_DebugPutc, 0, 1200);
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 */