/************************************************************************* * * * 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 "YapCompile.h" #include "clause.h" #include "eam.h" #include "eamamasm.h" #include #include Cell *inst_code; int pass=0; Cell *labels[1000]; Cell *Code_Start; Cell Area_Code[200000]; Cell area_code=0; extern Cell 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_unsafe_op: /* printf("Got a put_unsafe...\n"); emit_inst(_put_unsafe_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 { emit_inst(_put_val_Y_op); emit_par(ppc->new1); emit_par(Y_Var((Ventry *) 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_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_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_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_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 run_op: /* se ficar vazio, retirar no eam_am.c o +5 das linhas pc=clause->code+5 no only_1_clause e no call */ emit_inst(_try_me_op); emit_par(0); emit_par(0); emit_par(0); emit_par(0); 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_initialized_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 */