/************************************************************************* * * * Yap Prolog * * * * Yap Prolog was developed at NCCUP - Universidade do Porto * * * * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * * * ************************************************************************** * * * File: index.c * * Last rev: 5/2/88 * * mods: * * comments: Indexing a Prolog predicate * * * *************************************************************************/ #ifdef SCCS static char SccsId[] = "%W% %G%"; #endif /* * This file compiles and removes the indexation code for the prolog compiler * * Some remarks: *try_me always point to inside the code; * try always points to outside * Algorithm: - fetch info on all clauses - if #clauses =1 return - compute groups: seq of variable only clauses seq: of one or more type instructions bound clauses - sort group - select constant --> type instructions --> count constants --> switch for all arguments: select new argument */ #include "Yap.h" #include "compile.h" #include "clause.h" #include "index.h" #ifdef YAPOR #include "or.macros.h" #endif /* YAPOR */ #ifdef DEBUG #include "yapio.h" #endif #ifndef NULL #define NULL (void *)0 #endif #if HAVE_STRING_H #include #endif UInt STATIC_PROTO(do_index, (ClauseDef *,ClauseDef *,PredEntry *,UInt,UInt,int,int,CELL *)); UInt STATIC_PROTO(do_compound_index, (ClauseDef *,ClauseDef *,PredEntry *,UInt,UInt,UInt,int,int,int,CELL *)); static UInt labelno; static inline int smaller(Term t1, Term t2) { if (IsVarTerm(t1)) { if (!IsVarTerm(t2)) return TRUE; return (t1 < t2); } else if (IsIntTerm(t1)) { if (IsVarTerm(t2)) return FALSE; if (!IsIntTerm(t2)) return TRUE; return (IntOfTerm(t1) < IntOfTerm(t2)); } else if (IsAtomTerm(t1)) { if (IsVarTerm(t2) || IsIntTerm(t2)) return FALSE; if (IsApplTerm(t2) || IsPairTerm(t2)) return TRUE; return (t1 < t2); } else if (IsApplTerm(t1)) { if (IsVarTerm(t2) || IsAtomTerm(t2) || IsIntTerm(t2)) return FALSE; if (IsPairTerm(t2)) return TRUE; return (t1 < t2); } else /* if (IsPairTerm(t1)) */ { return FALSE; } } static inline void clcpy(ClauseDef *d, ClauseDef *s) { memcpy((void *)d, (void *)s, sizeof(ClauseDef)); } /* original code from In Hyuk Choi, found at http://userpages.umbc.edu/~ichoi1/project/cs441.htm */ static inline void exchange(ClauseDef b[], Int i, Int j) { ClauseDef t; clcpy(&t, b+j); clcpy(b+j, b+i); clcpy(b+i, &t); } static UInt partition(ClauseDef a[], Int p, Int r) { Term x; UInt i, j; x = a[p].Tag; i = p+1; j = r; while (smaller(x,a[j].Tag) && i < j) { j--; } while (smaller(a[i].Tag, x) && i < j) { i++; } while(i < j) { exchange(a, i, j); i++; j--; while (smaller(x, a[j].Tag) && i < j) { j--; } while (smaller(a[i].Tag, x) && i < j) { i++; } } if (smaller(x, a[i].Tag)) i--; exchange(a, p, i); return(i); } static void insort(ClauseDef a[], Int p, Int q) { Int j; for (j = p+1; j <= q; j ++) { ClauseDef key; Int i; clcpy(&key, a+j); i = j; while (i > p && smaller(key.Tag,a[i-1].Tag)) { clcpy(a+i, a+(i-1)); i --; } clcpy(a+i, &key); } } static void quicksort(ClauseDef a[], Int p, Int r) { Int q; if (p < r) { if (r - p < 100) { insort(a, p, r); return; } exchange(a, p, (p+r)/2); q = partition (a, p, r); quicksort(a, p, q-1); quicksort(a, q + 1, r); } } /* sort a group of clauses by using their tags */ static void sort_group(GroupDef *grp) { quicksort(grp->FirstClause, 0, grp->LastClause-grp->FirstClause); } /* add copy to register stack for original reg */ static int add_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy) { if (regs_count == MAX_REG_COPIES) { regs[0] = copy; } regs[regs_count] = copy; return regs_count+1; } /* add copy to register stack for original reg */ static int delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy) { int i = 0; while (i < regs_count) { if (regs[i] == copy) { /* we found it */ regs[i] = regs[MAX_REG_COPIES-1]; return regs_count-1; } i++; } /* this copy had overflowed */ return regs_count; } /* add copy to register stack for original reg */ inline static int regcopy_in(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy) { int i = 0; while (i < regs_count) { if (regs[i] == copy) { return TRUE; } i++; } /* this copy could not be found */ return FALSE; } /* Restores a prolog clause, in its compiled form */ static int has_cut(yamop *pc) /* * Cl points to the start of the code, IsolFlag tells if we have a single * clause for this predicate or not */ { do { op_numbers op = Yap_op_from_opcode(pc->opc); pc->opc = Yap_opcode(op); switch (op) { case _Ystop: case _Nstop: return FALSE; /* instructions type ld */ case _cut: case _cut_t: case _cut_e: case _p_cut_by_y: case _p_cut_by_x: case _comit_b_y: case _comit_b_x: return TRUE; case _try_me: case _retry_me: case _trust_me: case _profiled_retry_me: case _profiled_trust_me: case _count_retry_me: case _count_trust_me: case _try_me0: case _retry_me0: case _trust_me0: case _try_me1: case _retry_me1: case _trust_me1: case _try_me2: case _retry_me2: case _trust_me2: case _try_me3: case _retry_me3: case _trust_me3: case _try_me4: case _retry_me4: case _trust_me4: case _spy_or_trymark: case _try_and_mark: case _profiled_retry_and_mark: case _count_retry_and_mark: case _retry_and_mark: case _try_clause: case _retry: case _trust: #ifdef YAPOR case _getwork: case _getwork_seq: case _sync: #endif #ifdef TABLING case _table_try_me_single: case _table_try_me: case _table_retry_me: case _table_trust_me: case _table_answer_resolution: case _table_completion: #endif pc = NEXTOP(pc,ld); break; /* instructions type l */ case _enter_profiling: case _count_call: case _retry_profiled: case _count_retry: case _try_logical_pred: case _trust_logical_pred: case _execute: case _dexecute: case _jump: case _move_back: case _skip: case _jump_if_var: case _try_in: pc = NEXTOP(pc,l); break; /* instructions type EC */ case _alloc_for_logical_pred: pc = NEXTOP(pc,EC); break; /* instructions type e */ case _trust_fail: case _op_fail: case _procceed: case _allocate: case _deallocate: case _write_void: case _write_list: case _write_l_list: #if !defined(YAPOR) case _or_last: #endif case _pop: case _index_pred: case _undef_p: case _spy_pred: case _p_equal: case _p_dif: case _p_eq: case _p_functor: case _p_execute_tail: case _enter_a_profiling: case _count_a_call: #ifdef YAPOR case _getwork_first_time: #endif #ifdef TABLING case _trie_do_var: case _trie_trust_var: case _trie_try_var: case _trie_retry_var: case _trie_do_val: case _trie_trust_val: case _trie_try_val: case _trie_retry_val: case _trie_do_atom: case _trie_trust_atom: case _trie_try_atom: case _trie_retry_atom: case _trie_do_list: case _trie_trust_list: case _trie_try_list: case _trie_retry_list: case _trie_do_struct: case _trie_trust_struct: case _trie_try_struct: case _trie_retry_struct: #endif pc = NEXTOP(pc,e); break; /* instructions type x */ case _save_b_x: case _get_list: case _put_list: case _write_x_var: case _write_x_val: case _write_x_loc: case _p_atom_x: case _p_atomic_x: case _p_integer_x: case _p_nonvar_x: case _p_number_x: case _p_var_x: case _p_db_ref_x: case _p_primitive_x: case _p_compound_x: case _p_float_x: pc = NEXTOP(pc,x); break; /* instructions type y */ case _save_b_y: case _write_y_var: case _write_y_val: case _write_y_loc: case _p_atom_y: case _p_atomic_y: case _p_integer_y: case _p_nonvar_y: case _p_number_y: case _p_var_y: case _p_db_ref_y: case _p_primitive_y: case _p_compound_y: case _p_float_y: pc = NEXTOP(pc,y); break; /* instructions type sla */ case _p_execute: case _fcall: case _call: #ifdef YAPOR case _or_last: #endif pc = NEXTOP(pc,sla); break; /* instructions type sla, but for disjunctions */ case _either: case _or_else: pc = NEXTOP(pc,sla); break; /* instructions type sla, but for functions */ case _call_cpred: case _call_usercpred: pc = NEXTOP(pc,sla); break; /* instructions type xx */ case _get_x_var: case _get_x_val: case _glist_valx: case _gl_void_varx: case _gl_void_valx: case _put_x_var: case _put_x_val: pc = NEXTOP(pc,xx); break; /* instructions type yx */ case _get_y_var: case _get_y_val: case _put_y_var: case _put_y_val: case _put_unsafe: pc = NEXTOP(pc,yx); break; /* instructions type xc */ case _get_atom: case _put_atom: case _get_float: case _get_longint: case _get_bigint: pc = NEXTOP(pc,xc); break; /* instructions type xf */ case _get_struct: case _put_struct: pc = NEXTOP(pc,xf); break; /* instructions type xy */ case _glist_valy: case _gl_void_vary: case _gl_void_valy: pc = NEXTOP(pc,xy); break; /* instructions type ox */ case _unify_x_var: case _unify_x_var_write: case _unify_l_x_var: case _unify_l_x_var_write: case _unify_x_val_write: case _unify_x_val: case _unify_l_x_val_write: case _unify_l_x_val: case _unify_x_loc_write: case _unify_x_loc: case _unify_l_x_loc_write: case _unify_l_x_loc: case _save_pair_x_write: case _save_pair_x: case _save_appl_x_write: case _save_appl_x: pc = NEXTOP(pc,ox); break; /* instructions type oxx */ case _unify_x_var2: case _unify_x_var2_write: case _unify_l_x_var2: case _unify_l_x_var2_write: pc = NEXTOP(pc,oxx); break; /* instructions type oy */ case _unify_y_var: case _unify_y_var_write: case _unify_l_y_var: case _unify_l_y_var_write: case _unify_y_val_write: case _unify_y_val: case _unify_l_y_val_write: case _unify_l_y_val: case _unify_y_loc_write: case _unify_y_loc: case _unify_l_y_loc_write: case _unify_l_y_loc: case _save_pair_y_write: case _save_pair_y: case _save_appl_y_write: case _save_appl_y: pc = NEXTOP(pc,oy); break; /* instructions type o */ case _unify_void_write: case _unify_void: case _unify_l_void_write: case _unify_l_void: case _unify_list_write: case _unify_list: case _unify_l_list_write: case _unify_l_list: pc = NEXTOP(pc,o); break; /* instructions type os */ case _unify_n_voids_write: case _unify_n_voids: case _unify_l_n_voids_write: case _unify_l_n_voids: pc = NEXTOP(pc,os); break; /* instructions type oc */ case _unify_atom_write: case _unify_atom: case _unify_l_atom_write: case _unify_l_atom: case _unify_float: case _unify_l_float: case _unify_longint: case _unify_l_longint: case _unify_bigint: case _unify_l_bigint: pc = NEXTOP(pc,oc); break; /* instructions type osc */ case _unify_n_atoms_write: case _unify_n_atoms: pc = NEXTOP(pc,osc); break; /* instructions type of */ case _unify_struct_write: case _unify_struct: case _unify_l_struc_write: case _unify_l_struc: pc = NEXTOP(pc,of); break; /* instructions type s */ case _write_n_voids: case _pop_n: #ifdef TABLING case _table_new_answer: #endif pc = NEXTOP(pc,s); break; /* instructions type ps */ case _write_atom: pc = NEXTOP(pc,c); break; /* instructions type sc */ case _write_n_atoms: pc = NEXTOP(pc,sc); break; /* instructions type f */ case _write_struct: case _write_l_struc: pc = NEXTOP(pc,f); break; /* instructions type sdl */ case _call_c_wfail: pc = NEXTOP(pc,sdl); break; /* instructions type lds */ case _try_c: case _try_userc: pc = NEXTOP(pc,lds); break; case _retry_c: case _retry_userc: pc = NEXTOP(pc,lds); break; /* instructions type llll */ case _switch_on_type: pc = NEXTOP(pc,llll); break; case _switch_list_nl: pc = NEXTOP(pc,ollll); break; case _switch_on_arg_type: pc = NEXTOP(pc,xllll); break; case _switch_on_sub_arg_type: pc = NEXTOP(pc,sllll); break; /* instructions type lll */ /* instructions type cll */ case _if_not_then: pc = NEXTOP(pc,cll); break; /* instructions type ollll */ case _switch_on_func: case _switch_on_cons: case _if_func: case _if_cons: { int i; CELL *startcode; i = pc->u.s.s; startcode = (CELL *)NEXTOP(pc,s); pc = (yamop *)(startcode+2*i); } break; case _go_on_func: pc = NEXTOP(pc,fll); break; /* instructions type cll */ case _go_on_cons: pc = NEXTOP(pc,cll); break; /* instructions type xxx */ case _p_plus_vv: case _p_minus_vv: case _p_times_vv: case _p_div_vv: case _p_and_vv: case _p_or_vv: case _p_sll_vv: case _p_slr_vv: case _p_arg_vv: case _p_func2s_vv: case _p_func2f_xx: pc = NEXTOP(pc,xxx); break; /* instructions type xxc */ case _p_plus_vc: case _p_minus_cv: case _p_times_vc: case _p_div_cv: case _p_and_vc: case _p_or_vc: case _p_sll_vc: case _p_slr_vc: case _p_func2s_vc: pc = NEXTOP(pc,xxc); break; case _p_div_vc: case _p_sll_cv: case _p_slr_cv: case _p_arg_cv: pc = NEXTOP(pc,xcx); break; case _p_func2s_cv: pc = NEXTOP(pc,xcx); break; /* instructions type xyx */ case _p_func2f_xy: pc = NEXTOP(pc,xyx); break; /* instructions type yxx */ case _p_plus_y_vv: case _p_minus_y_vv: case _p_times_y_vv: case _p_div_y_vv: case _p_and_y_vv: case _p_or_y_vv: case _p_sll_y_vv: case _p_slr_y_vv: case _p_arg_y_vv: case _p_func2s_y_vv: case _p_func2f_yx: pc = NEXTOP(pc,yxx); break; /* instructions type yyx */ case _p_func2f_yy: pc = NEXTOP(pc,yyx); break; /* instructions type yxc */ case _p_plus_y_vc: case _p_minus_y_cv: case _p_times_y_vc: case _p_div_y_vc: case _p_div_y_cv: case _p_and_y_vc: case _p_or_y_vc: case _p_sll_y_vc: case _p_slr_y_vc: case _p_func2s_y_vc: pc = NEXTOP(pc,yxc); break; /* instructions type ycx */ case _p_sll_y_cv: case _p_slr_y_cv: case _p_arg_y_cv: pc = NEXTOP(pc,ycx); break; /* instructions type lxx */ case _p_func2s_y_cv: pc = NEXTOP(pc,ycx); break; /* instructions type lxx */ case _call_bfunc_xx: pc = NEXTOP(pc,lxx); break; /* instructions type lxy */ case _call_bfunc_yx: case _call_bfunc_xy: pc = NEXTOP(pc,lxy); break; case _call_bfunc_yy: pc = NEXTOP(pc,lyy); break; } } while (TRUE); } static void add_info(ClauseDef *clause, UInt regno) { wamreg myregs[MAX_REG_COPIES]; int nofregs; yslot ycopy = 0; yamop *cl; nofregs = add_regcopy(myregs, 0, Yap_regnotoreg(regno)); cl = clause->CurrentCode; while (TRUE) { op_numbers op = Yap_op_from_opcode(cl->opc); switch (op) { case _Ystop: case _Nstop: case _try_me: case _retry_me: case _trust_me: case _profiled_retry_me: case _profiled_trust_me: case _count_retry_me: case _count_trust_me: case _try_me0: case _retry_me0: case _trust_me0: case _try_me1: case _retry_me1: case _trust_me1: case _try_me2: case _retry_me2: case _trust_me2: case _try_me3: case _retry_me3: case _trust_me3: case _try_me4: case _retry_me4: case _trust_me4: case _spy_or_trymark: case _try_and_mark: case _profiled_retry_and_mark: case _count_retry_and_mark: case _retry_and_mark: case _try_clause: case _retry: case _trust: #ifdef YAPOR case _getwork: case _getwork_seq: case _sync: #endif #ifdef TABLING case _table_try_me_single: case _table_try_me: case _table_retry_me: case _table_trust_me: case _table_answer_resolution: case _table_completion: #endif case _enter_profiling: case _count_call: case _retry_profiled: case _count_retry: case _try_logical_pred: case _trust_logical_pred: case _execute: case _dexecute: case _jump: case _move_back: case _skip: case _jump_if_var: case _try_in: clause->Tag = (CELL)NULL; return; case _alloc_for_logical_pred: cl = NEXTOP(cl,EC); break; /* instructions type e */ case _trust_fail: case _op_fail: case _procceed: #if !defined(YAPOR) case _or_last: #endif case _pop: case _index_pred: case _undef_p: case _spy_pred: case _p_equal: case _p_dif: case _p_eq: case _p_functor: case _p_execute_tail: #ifdef YAPOR case _getwork_first_time: #endif #ifdef TABLING case _trie_do_var: case _trie_trust_var: case _trie_try_var: case _trie_retry_var: case _trie_do_val: case _trie_trust_val: case _trie_try_val: case _trie_retry_val: case _trie_do_atom: case _trie_trust_atom: case _trie_try_atom: case _trie_retry_atom: case _trie_do_list: case _trie_trust_list: case _trie_try_list: case _trie_retry_list: case _trie_do_struct: case _trie_trust_struct: case _trie_try_struct: case _trie_retry_struct: #endif clause->Tag = (CELL)NULL; return; case _cut: case _cut_t: case _cut_e: case _allocate: case _deallocate: case _write_void: case _write_list: case _write_l_list: case _enter_a_profiling: case _count_a_call: cl = NEXTOP(cl,e); break; case _save_b_x: case _comit_b_x: case _p_cut_by_x: case _write_x_val: case _write_x_loc: case _write_x_var: case _put_list: case _p_nonvar_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,x); break; case _p_number_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_number+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_atomic_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_atomic+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_integer_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_integer+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_primitive_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_primitive+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_compound_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_compound+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_var_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_var+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _p_db_ref_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = AbsAppl((CELL *)FunctorDBRef); return; } cl = NEXTOP(cl,x); break; case _p_float_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = AbsAppl((CELL *)FunctorDouble); return; } cl = NEXTOP(cl,x); break; case _p_atom_x: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = (_atom+1)*sizeof(CELL); return; } cl = NEXTOP(cl,x); break; case _get_list: if (regcopy_in(myregs, nofregs, cl->u.x.x)) { clause->Tag = AbsPair(NULL); clause->WorkPC = NEXTOP(cl,x); return; } cl = NEXTOP(cl,x); break; case _save_b_y: case _comit_b_y: case _write_y_var: case _write_y_val: case _write_y_loc: case _p_cut_by_y: case _p_nonvar_y: if (cl->u.y.y == ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,y); break; case _p_atomic_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = (_atomic+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_integer_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = (_integer+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_number_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = (_number+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_primitive_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = (_primitive+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_compound_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = (_compound+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_db_ref_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = AbsAppl((CELL *)FunctorDBRef); return; } cl = NEXTOP(cl,y); break; case _p_float_y: if (ycopy == cl->u.y.y) { clause->WorkPC = cl; clause->Tag = AbsAppl((CELL *)FunctorDouble); return; } cl = NEXTOP(cl,y); break; case _p_atom_y: if (cl->u.y.y == ycopy) { clause->Tag = (_atom+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_var_y: if (cl->u.y.y == ycopy) { clause->Tag = (_var+1)*sizeof(CELL); return; } cl = NEXTOP(cl,y); break; case _p_execute: case _fcall: case _call: #ifdef YAPOR case _or_last: #endif case _either: case _or_else: case _call_cpred: case _call_usercpred: clause->Tag = (CELL)NULL; return; case _get_x_var: if (regcopy_in(myregs, nofregs, cl->u.xx.xr)) { nofregs = add_regcopy(myregs, nofregs, cl->u.xx.xl); cl = NEXTOP(cl,xx); break; } case _put_x_var: /* if the last slot I am using, get out */ if (regcopy_in(myregs, nofregs, cl->u.xx.xl) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xx.xl)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xx); break; case _get_x_val: /* alias two registers */ if (regcopy_in(myregs, nofregs, cl->u.xx.xl)) { nofregs = add_regcopy(myregs, nofregs, cl->u.xx.xr); } else if (regcopy_in(myregs, nofregs, cl->u.xx.xr)) { nofregs = add_regcopy(myregs, nofregs, cl->u.xx.xl); } cl = NEXTOP(cl,xx); break; case _put_x_val: if (regcopy_in(myregs, nofregs, cl->u.xx.xl)) { nofregs = add_regcopy(myregs, nofregs, cl->u.xx.xr); } else if (regcopy_in(myregs, nofregs, cl->u.xx.xr) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xx.xr)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xx); break; case _glist_valx: case _gl_void_varx: case _gl_void_valx: if (regcopy_in(myregs, nofregs, cl->u.xx.xl)) { clause->WorkPC = cl; clause->Tag = AbsPair(NULL); return; } cl = NEXTOP(cl,xx); break; case _get_y_var: if (regcopy_in(myregs, nofregs, cl->u.xx.xr)) { ycopy = cl->u.yx.y; } case _put_y_var: cl = NEXTOP(cl,yx); break; case _put_y_val: case _put_unsafe: if (regcopy_in(myregs, nofregs, cl->u.yx.x)) { ycopy = cl->u.yx.y; } cl = NEXTOP(cl,yx); break; case _get_y_val: if (regcopy_in(myregs, nofregs, cl->u.xy.x)) { ycopy = cl->u.yx.y; } else if (ycopy == cl->u.yx.y) { nofregs = add_regcopy(myregs, nofregs, cl->u.xy.x); } cl = NEXTOP(cl,xy); break; case _get_atom: if (regcopy_in(myregs, nofregs, cl->u.xc.x)) { clause->Tag = cl->u.xc.c; return; } else { cl = NEXTOP(cl,xc); } break; case _get_float: if (regcopy_in(myregs, nofregs, cl->u.xc.x)) { clause->WorkPC = cl; clause->Tag = AbsAppl((CELL *)FunctorDouble); return; } else { cl = NEXTOP(cl,xc); } break; case _get_longint: if (regcopy_in(myregs, nofregs, cl->u.xc.x)) { clause->WorkPC = cl; clause->Tag = AbsAppl((CELL *)FunctorLongInt); return; } else { cl = NEXTOP(cl,xc); } break; case _get_bigint: if (regcopy_in(myregs, nofregs, cl->u.xc.x)) { clause->WorkPC = cl; #ifdef USE_GMP clause->Tag = AbsAppl((CELL *)FunctorBigInt); #else clause->Tag = AbsAppl((CELL *)FunctorLongInt); #endif return; } else { cl = NEXTOP(cl,xc); } break; case _put_atom: if (regcopy_in(myregs, nofregs, cl->u.xc.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xc.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } else { cl = NEXTOP(cl,xc); } break; case _get_struct: if (regcopy_in(myregs, nofregs, cl->u.xf.x)) { clause->WorkPC = NEXTOP(cl,xf); clause->Tag = AbsAppl((CELL *)cl->u.xf.f); return; } else { cl = NEXTOP(cl,xf); } break; case _put_struct: if (regcopy_in(myregs, nofregs, cl->u.xf.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xf.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } else { cl = NEXTOP(cl,xf); } break; case _glist_valy: case _gl_void_vary: case _gl_void_valy: if (regcopy_in(myregs, nofregs, cl->u.xy.x)) { clause->WorkPC = cl; clause->Tag = AbsPair(NULL); return; } cl = NEXTOP(cl,xy); break; case _unify_x_var: case _unify_x_var_write: case _unify_l_x_var: case _unify_l_x_var_write: if (regcopy_in(myregs, nofregs, cl->u.ox.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.ox.x)) == 0 && !ycopy) { /* we just initialised the argument, so nothing can happen now */ clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,ox); break; case _unify_x_val_write: case _unify_x_val: case _unify_l_x_val_write: case _unify_l_x_val: case _unify_x_loc_write: case _unify_x_loc: case _unify_l_x_loc_write: case _unify_l_x_loc: /* we're just done with the head of a list, but there is nothing inside. */ cl = NEXTOP(cl,ox); break; case _save_pair_x_write: case _save_pair_x: case _save_appl_x_write: case _save_appl_x: if (regcopy_in(myregs, nofregs, cl->u.ox.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.ox.x)) == 0 && !ycopy) { /* we just initialised the argument, so nothing can happen now */ clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,ox); break; case _unify_x_var2: case _unify_x_var2_write: case _unify_l_x_var2: case _unify_l_x_var2_write: if (regcopy_in(myregs, nofregs, cl->u.oxx.xl) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.oxx.xl)) == 0 && !ycopy) { /* we just initialised the argument, so nothing can happen now */ clause->Tag = (CELL)NULL; return; } if (regcopy_in(myregs, nofregs, cl->u.oxx.xr) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.oxx.xr)) == 0 && !ycopy) { /* we just initialised the argument, so nothing can happen now */ clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,oxx); break; case _unify_y_var: case _unify_y_var_write: case _unify_l_y_var: case _unify_l_y_var_write: /* we're just done with the head of a list, but there is nothing inside. */ if (cl->u.oy.y == ycopy) { ycopy = 0; /* weird stuff, let's just reset ycopy */ if (nofregs == 0) { clause->Tag = (CELL)NULL; return; } } cl = NEXTOP(cl,oy); break; case _unify_y_val_write: case _unify_y_val: case _unify_l_y_val_write: case _unify_l_y_val: case _unify_y_loc_write: case _unify_y_loc: case _unify_l_y_loc_write: case _unify_l_y_loc: /* we're just done with the head of a list, but there is nothing inside. */ cl = NEXTOP(cl,oy); break; case _save_pair_y_write: case _save_pair_y: case _save_appl_y_write: case _save_appl_y: if (cl->u.oy.y == ycopy) { ycopy = 0; /* weird stuff, let's just reset ycopy */ if (nofregs == 0) { clause->Tag = (CELL)NULL; return; } } cl = NEXTOP(cl,oy); break; case _unify_void_write: case _unify_void: case _unify_l_void_write: case _unify_l_void: /* we're just done with the head of a list, but there is nothing inside. */ cl = NEXTOP(cl,o); break; case _unify_list_write: case _unify_list: case _unify_l_list_write: case _unify_l_list: cl = NEXTOP(cl,o); break; case _unify_n_voids_write: case _unify_n_voids: case _unify_l_n_voids_write: case _unify_l_n_voids: cl = NEXTOP(cl,os); break; case _unify_atom_write: case _unify_atom: case _unify_l_atom_write: case _unify_l_atom: cl = NEXTOP(cl,oc); break; case _unify_float: case _unify_l_float: cl = NEXTOP(cl,oc); break; case _unify_longint: case _unify_l_longint: cl = NEXTOP(cl,oc); break; case _unify_bigint: case _unify_l_bigint: cl = NEXTOP(cl,oc); break; case _unify_n_atoms_write: case _unify_n_atoms: cl = NEXTOP(cl,osc); break; case _unify_struct_write: case _unify_struct: case _unify_l_struc_write: case _unify_l_struc: cl = NEXTOP(cl,of); break; case _write_n_voids: case _pop_n: cl = NEXTOP(cl,s); break; case _write_atom: cl = NEXTOP(cl,c); break; case _write_n_atoms: cl = NEXTOP(cl,sc); break; case _write_struct: case _write_l_struc: cl = NEXTOP(cl,f); break; case _call_c_wfail: case _try_c: case _try_userc: case _retry_c: case _retry_userc: case _switch_on_type: case _switch_list_nl: case _switch_on_arg_type: case _switch_on_sub_arg_type: case _if_not_then: case _switch_on_func: case _switch_on_cons: case _go_on_func: case _go_on_cons: case _if_func: case _if_cons: clause->Tag = (CELL)NULL; return; case _p_plus_vv: case _p_minus_vv: case _p_times_vv: case _p_div_vv: case _p_and_vv: case _p_or_vv: case _p_sll_vv: case _p_slr_vv: case _p_arg_vv: case _p_func2s_vv: case _p_func2f_xx: if (regcopy_in(myregs, nofregs, cl->u.xxx.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xxx.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xxx); break; case _p_plus_vc: case _p_minus_cv: case _p_times_vc: case _p_div_cv: case _p_and_vc: case _p_or_vc: case _p_sll_vc: case _p_slr_vc: case _p_func2s_vc: if (regcopy_in(myregs, nofregs, cl->u.xxc.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xxc.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xxc); break; case _p_div_vc: case _p_sll_cv: case _p_slr_cv: case _p_arg_cv: case _p_func2s_cv: if (regcopy_in(myregs, nofregs, cl->u.xcx.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xcx.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xcx); break; case _p_func2f_xy: if (regcopy_in(myregs, nofregs, cl->u.xyx.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.xyx.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,xyx); break; case _p_plus_y_vv: case _p_minus_y_vv: case _p_times_y_vv: case _p_div_y_vv: case _p_and_y_vv: case _p_or_y_vv: case _p_sll_y_vv: case _p_slr_y_vv: case _p_arg_y_vv: case _p_func2s_y_vv: case _p_func2f_yx: if (cl->u.yxx.y == ycopy) { ycopy = 0; /* weird stuff, let's just reset ycopy */ if (nofregs == 0) { clause->Tag = (CELL)NULL; return; } } cl = NEXTOP(cl,yxx); break; case _p_func2f_yy: if (regcopy_in(myregs, nofregs, cl->u.yyx.x) && (nofregs = delete_regcopy(myregs, nofregs, cl->u.yyx.x)) == 0 && !ycopy) { clause->Tag = (CELL)NULL; return; } cl = NEXTOP(cl,yyx); break; case _p_plus_y_vc: case _p_minus_y_cv: case _p_times_y_vc: case _p_div_y_vc: case _p_div_y_cv: case _p_and_y_vc: case _p_or_y_vc: case _p_sll_y_vc: case _p_slr_y_vc: case _p_func2s_y_vc: if (cl->u.yxc.y == ycopy) { ycopy = 0; /* weird stuff, let's just reset ycopy */ if (nofregs == 0) { clause->Tag = (CELL)NULL; return; } } cl = NEXTOP(cl,yxc); break; case _p_sll_y_cv: case _p_slr_y_cv: case _p_arg_y_cv: case _p_func2s_y_cv: if (cl->u.ycx.y == ycopy) { ycopy = 0; /* weird stuff, let's just reset ycopy */ if (nofregs == 0) { clause->Tag = (CELL)NULL; return; } } cl = NEXTOP(cl,ycx); break; case _call_bfunc_xx: cl = NEXTOP(cl,lxx); break; case _call_bfunc_yx: case _call_bfunc_xy: cl = NEXTOP(cl,lxy); break; case _call_bfunc_yy: cl = NEXTOP(cl,lyy); break; } } } static void move_next(ClauseDef *clause, UInt regno) { yamop *cl = clause->CurrentCode; wamreg wreg = Yap_regnotoreg(regno); op_numbers op = Yap_op_from_opcode(cl->opc); switch (op) { case _p_db_ref_x: case _p_float_x: if (wreg == cl->u.x.x) { clause->CurrentCode = NEXTOP(cl,x); } return; case _get_list: if (wreg == cl->u.x.x) { clause->CurrentCode = NEXTOP(cl,x); } return; case _get_atom: case _get_float: case _get_longint: case _get_bigint: if (wreg == cl->u.xc.x) { clause->CurrentCode = NEXTOP(cl,xc); } return; case _get_struct: if (wreg == cl->u.xf.x) { clause->CurrentCode = NEXTOP(cl,xf); } default: return; } } static void add_arg_info(ClauseDef *clause, UInt argno) { yamop *cl = clause->WorkPC; while (TRUE) { op_numbers op = Yap_op_from_opcode(cl->opc); switch (op) { case _glist_valx: if (argno == 1) { clause->Tag = (CELL)NULL; return; } argno--; cl = NEXTOP(cl,xx); break; case _gl_void_vary: case _gl_void_valy: case _gl_void_varx: case _gl_void_valx: clause->Tag = (CELL)NULL; return; case _glist_valy: if (argno == 1) { clause->Tag = (CELL)NULL; return; } argno--; cl = NEXTOP(cl,xy); break; case _unify_l_x_var: case _unify_l_x_val: case _unify_l_x_loc: case _unify_x_var: case _unify_x_val: case _unify_x_loc: if (argno == 1) { clause->Tag = (CELL)NULL; return; } argno--; case _unify_l_x_var_write: case _unify_l_x_val_write: case _unify_l_x_loc_write: case _unify_x_var_write: case _unify_x_val_write: case _unify_x_loc_write: cl = NEXTOP(cl,ox); break; case _save_pair_x_write: case _save_pair_x: case _save_appl_x_write: case _save_appl_x: cl = NEXTOP(cl,ox); break; case _unify_l_x_var2: case _unify_x_var2: if (argno == 1 || argno == 2) { clause->Tag = (CELL)NULL; return; } argno -= 2; case _unify_l_x_var2_write: case _unify_x_var2_write: cl = NEXTOP(cl,oxx); break; case _unify_y_var: case _unify_y_val: case _unify_y_loc: case _unify_l_y_var: case _unify_l_y_val: case _unify_l_y_loc: /* we're just done with the head of a list, but there is nothing inside. */ if (argno == 1) { clause->Tag = (CELL)NULL; return; } argno--; case _unify_y_var_write: case _unify_y_val_write: case _unify_y_loc_write: case _unify_l_y_var_write: case _unify_l_y_val_write: case _unify_l_y_loc_write: cl = NEXTOP(cl,oy); break; case _save_pair_y_write: case _save_pair_y: case _save_appl_y_write: case _save_appl_y: cl = NEXTOP(cl,oy); break; case _unify_l_void: case _unify_void: if (argno == 1) { clause->Tag = (CELL)NULL; return; } argno--; case _unify_l_void_write: case _unify_void_write: cl = NEXTOP(cl,o); break; case _unify_list: case _unify_l_list: if (argno == 1) { clause->Tag = AbsPair(NULL); return; } argno += 1; /* 2-1: have two extra arguments to skip */ case _unify_list_write: case _unify_l_list_write: cl = NEXTOP(cl,o); break; case _unify_n_voids: case _unify_l_n_voids: if (argno <= cl->u.os.s) { clause->Tag = (CELL)NULL; return; } argno -= cl->u.os.s; case _unify_n_voids_write: case _unify_l_n_voids_write: cl = NEXTOP(cl,os); break; case _unify_atom: case _unify_l_atom: if (argno == 1) { clause->Tag = cl->u.oc.c; return; } argno--; case _unify_atom_write: case _unify_l_atom_write: cl = NEXTOP(cl,oc); break; case _unify_l_float: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorDouble); return; } argno--; case _unify_longint: case _unify_l_longint: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorLongInt); return; } argno--; case _unify_bigint: case _unify_l_bigint: if (argno == 1) { #ifdef USE_GMP clause->Tag = AbsAppl((CELL *)FunctorBigInt); #else clause->Tag = AbsAppl((CELL *)FunctorLongInt); #endif return; } argno--; case _unify_n_atoms: if (argno <= cl->u.osc.s) { clause->Tag = cl->u.osc.c; return; } argno -= cl->u.osc.s; case _unify_n_atoms_write: cl = NEXTOP(cl,osc); break; case _unify_struct: case _unify_l_struc: if (argno == 1) { clause->Tag = AbsAppl((CELL *)cl->u.of.f); return; } argno--; case _unify_l_struc_write: case _unify_struct_write: cl = NEXTOP(cl,of); break; case _pop: cl = NEXTOP(cl,e); break; case _pop_n: cl = NEXTOP(cl,s); break; default: return; } } } static void skip_to_arg(ClauseDef *clause, UInt argno, int at_point) { yamop *cl = clause->WorkPC; int done = FALSE; at_point = at_point & (clause->WorkPC == clause->CurrentCode); while (!done) { op_numbers op = Yap_op_from_opcode(cl->opc); switch (op) { case _glist_valx: at_point = FALSE; cl = NEXTOP(cl,xx); if (argno == 1) { clause->WorkPC=cl; done = TRUE; } else { /* looking to adjust workpc */ argno--; } break; case _gl_void_vary: case _gl_void_valy: if (argno == 2) { clause->WorkPC = NEXTOP(cl,xy); } else { clause->WorkPC = cl; } done = TRUE; break; case _gl_void_varx: case _gl_void_valx: if (argno == 2) { clause->WorkPC = NEXTOP(cl,xx); } else { clause->WorkPC = cl; } done = TRUE; break; case _glist_valy: done = TRUE; at_point = FALSE; clause->WorkPC = NEXTOP(cl,xy); break; case _unify_l_x_var: case _unify_l_x_val: case _unify_l_x_loc: case _unify_x_var: case _unify_x_val: case _unify_x_loc: if (argno == 1) { clause->WorkPC = NEXTOP(cl,ox); done = TRUE; } else { argno--; at_point = FALSE; } case _unify_l_x_var_write: case _unify_l_x_val_write: case _unify_l_x_loc_write: case _unify_x_var_write: case _unify_x_val_write: case _unify_x_loc_write: cl = NEXTOP(cl,ox); break; case _save_pair_x_write: case _save_pair_x: case _save_appl_x_write: case _save_appl_x: at_point = FALSE; cl = NEXTOP(cl,ox); break; case _unify_l_x_var2: case _unify_x_var2: at_point = FALSE; if (argno == 1 || argno == 2) { if (argno == 2) { clause->WorkPC = NEXTOP(cl,oxx); } else { clause->WorkPC = cl; } done = TRUE; } else { argno -= 2; } case _unify_l_x_var2_write: case _unify_x_var2_write: break; case _unify_y_var: case _unify_y_val: case _unify_y_loc: case _unify_l_y_var: case _unify_l_y_val: case _unify_l_y_loc: /* we're just done with the head of a list, but there is nothing inside. */ at_point = FALSE; if (argno == 1) { clause->WorkPC = NEXTOP(cl,oy); done = TRUE; } else { argno--; } case _unify_y_var_write: case _unify_y_val_write: case _unify_y_loc_write: case _unify_l_y_var_write: case _unify_l_y_val_write: case _unify_l_y_loc_write: cl = NEXTOP(cl,oy); break; case _save_pair_y_write: case _save_pair_y: case _save_appl_y_write: case _save_appl_y: at_point = FALSE; cl = NEXTOP(cl,oy); break; case _unify_l_void: case _unify_void: if (argno == 1) { done = TRUE; } else { argno--; } case _unify_l_void_write: case _unify_void_write: cl = NEXTOP(cl,o); break; case _unify_list: case _unify_l_list: if (argno == 1) { clause->WorkPC = NEXTOP(cl,o); done = TRUE; } else { argno += 1; /* 2-1: have two extra arguments to skip */ at_point = FALSE; } case _unify_list_write: case _unify_l_list_write: cl = NEXTOP(cl,o); break; case _unify_n_voids: case _unify_l_n_voids: if (argno <= cl->u.os.s) { clause->WorkPC = cl; done = TRUE; } else { argno -= cl->u.os.s; } case _unify_n_voids_write: case _unify_l_n_voids_write: cl = NEXTOP(cl,os); break; case _unify_atom: case _unify_l_atom: case _unify_longint: case _unify_l_longint: case _unify_bigint: case _unify_l_bigint: case _unify_l_float: if (argno == 1) { clause->WorkPC = NEXTOP(cl,oc); done = TRUE; } else { at_point = FALSE; argno--; } case _unify_atom_write: case _unify_l_atom_write: cl = NEXTOP(cl,oc); break; case _unify_n_atoms: if (argno <= cl->u.osc.s) { if (argno == cl->u.osc.s) { clause->WorkPC = NEXTOP(cl,oc); } else { clause->WorkPC = cl; at_point = FALSE; } done = TRUE; } else { at_point = FALSE; argno -= cl->u.osc.s; } case _unify_n_atoms_write: cl = NEXTOP(cl,osc); break; case _unify_struct: case _unify_l_struc: if (argno == 1) { clause->WorkPC = NEXTOP(cl,of); done = TRUE; } else { at_point = FALSE; argno--; } case _unify_l_struc_write: case _unify_struct_write: cl = NEXTOP(cl,of); break; case _pop: cl = NEXTOP(cl,e); break; case _pop_n: cl = NEXTOP(cl,s); break; default: done = TRUE; } } if (at_point) { clause->CurrentCode = clause->WorkPC; } else { clause->CurrentCode = clause->Code; } } static UInt groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp) { UInt groups = 0; while(min <= max) { grp->FirstClause = min; grp->AtomClauses = 0; grp->PairClauses = 0; grp->StructClauses = 0; grp->TestClauses = 0; if (min->Tag == (_var+1)*sizeof(CELL)) { min++; continue; } /* only do this for the first clauses in a group */ if (IsVarTerm(min->Tag)) { ClauseDef *clp = min+1; grp->VarClauses = 1; do { if (clp > max || !IsVarTerm(clp->Tag)) { grp->LastClause = (min = clp)-1; break; } clp++; if (clp->Tag != (_var+1)*sizeof(CELL)) grp->VarClauses++; } while (TRUE); } else { grp->VarClauses = 0; do { restart_loop: if (IsAtomTerm(min->Tag) || IsIntTerm(min->Tag)) { grp->AtomClauses++; } else if (IsPairTerm(min->Tag)) { grp->PairClauses++; } else if (IsApplTerm(min->Tag)) { grp->StructClauses++; } else { grp->TestClauses++; } min++; } while (min <= max && (!IsVarTerm(min->Tag))); if (min <= max && min->Tag == (_var+1)*sizeof(CELL)) { min++; goto restart_loop; } grp->LastClause = min-1; } groups++; grp++; } return groups; } static UInt new_label(void) { UInt lbl = labelno; labelno += 2; return lbl; } static void emit_trust(ClauseDef *cl, PredEntry *ap, UInt nxtlbl, int clauses) { if (CurrentPred->PredFlags & ProfiledPredFlag) { Yap_emit(retry_profiled_op, Unsigned(ap), Zero); } if (CurrentPred->PredFlags & CountPredFlag) { Yap_emit(count_retry_op, Unsigned(ap), Zero); } if (clauses == 0) { Yap_emit(trust_op, (CELL)(cl->Code), has_cut(cl->CurrentCode) ); } else { Yap_emit(retry_op, (CELL)(cl->Code), (clauses << 1) | has_cut(cl->CurrentCode) ); Yap_emit(jump_op, nxtlbl, Zero); } } static void emit_retry(ClauseDef *cl, PredEntry *ap, int clauses) { if (CurrentPred->PredFlags & ProfiledPredFlag) { Yap_emit(retry_profiled_op, Unsigned(ap), Zero); } if (CurrentPred->PredFlags & CountPredFlag) { Yap_emit(count_retry_op, Unsigned(ap), Zero); } Yap_emit(retry_op, (CELL)(cl->Code), (clauses << 1) | has_cut(cl->CurrentCode) ); } static void emit_try(ClauseDef *cl, PredEntry *ap, int var_group, int first, int clauses, int clleft, UInt nxtlbl) { /* var group */ if (var_group || clauses == 0) { if (first) { Yap_emit(try_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode) ); } else if (clleft+clauses) { Yap_emit(retry_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode) ); } else { Yap_emit(trust_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode)); } } else if (clleft == 0) { /* last group */ Yap_emit(try_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode)); } else { /* nonvar group */ Yap_emit(try_in_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode) ); } } static TypeSwitch * emit_type_switch(compiler_vm_op op) { return (TypeSwitch *)Yap_emit_extra_size(op, 0, sizeof(TypeSwitch)); } static AtomSwiEntry * emit_cswitch(int n, UInt fail_l) { compiler_vm_op op; AtomSwiEntry *target; if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, i; while (cases < n+1) cases *= 2; n = cases; op = switch_c_op; target = (AtomSwiEntry *)Yap_emit_extra_size(op, Unsigned(n), n*sizeof(FuncSwiEntry)); for (i=0; i MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, hash, d; AtomSwiEntry *hentry; while (cases < n+1) cases *= 2; hash = (wt >> HASH_SHIFT) & (cases-1); hentry = cebase + hash; d = (cases-1) & (wt|1); while (hentry->Tag != Zero) { #ifdef DEBUG #ifdef CLASHES ++clashes; #endif /* CLASHES */ #endif /* DEBUG */ hash = (hash + d) & (cases-1); hentry = cebase + hash; } return hentry; } else { return cebase + i; } } static FuncSwiEntry * emit_fswitch(int n, UInt fail_l) { compiler_vm_op op; FuncSwiEntry *target; if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, i; while (cases < n+1) cases *= 2; n = cases; op = switch_f_op; target = (FuncSwiEntry *)Yap_emit_extra_size(op, Unsigned(n), n*sizeof(FuncSwiEntry)); for (i=0; i MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, hash, d; FuncSwiEntry *hentry; Term wt = (CELL)ft; while (cases < n+1) cases *= 2; hash = (wt >> HASH_SHIFT) & (cases-1); hentry = febase + hash; d = (cases-1) & (wt|1); while (hentry->Tag != NULL) { #ifdef DEBUG #ifdef CLASHES ++clashes; #endif /* CLASHES */ #endif /* DEBUG */ hash = (hash + d) & (cases-1); hentry = febase + hash; } return hentry; } else { return febase + i; } } /* we assume there is at least one clause, that is, c0 < cf */ static void do_var_clauses(ClauseDef *c0, ClauseDef *cf, int var_group, PredEntry *ap, UInt labl, int first, int clleft, UInt nxtlbl) { Yap_emit(label_op, labl, Zero); if (c0 == cf) { emit_try(c0, ap, var_group, first, 0, clleft, nxtlbl); } else { if (c0 < cf) { emit_try(c0, ap, var_group, first, cf-c0, clleft, nxtlbl); } c0++; while (c0 < cf) { emit_retry(c0, ap, clleft+(cf-c0)); c0++; } if (c0 == cf) { emit_trust(c0, ap, nxtlbl, clleft); } } } static void do_var_group(GroupDef *grp, PredEntry *ap, UInt labl, int var_group, int first, int clleft, UInt nxtlbl) { return do_var_clauses(grp->FirstClause, grp->LastClause, var_group, ap, labl, first, clleft, nxtlbl); } static void add_lu_cl_info(yamop *codep) { LogUpdClause *cl = ClauseCodeToLogUpdClause(codep); if (cl->ClFlags & LogUpdRuleMask) { cl->u2.ClExt->u.EC.ClRefs++; } else { cl->u2.ClUse++; } } static UInt log_update_chain(PredEntry *ap) { yamop *codep = ap->cs.p_code.FirstClause; yamop *lastp = ap->cs.p_code.LastClause; Yap_emit(label_op, 1, Zero); Yap_emit(try_op, (CELL)NEXTOP(codep,ld), Zero); add_lu_cl_info(codep); codep = NextClause(codep); while (codep != lastp) { Yap_emit(retry_op, (CELL)NEXTOP(codep,ld), Zero); add_lu_cl_info(codep); codep = NextClause(codep); } Yap_emit(trust_op, (CELL)NEXTOP(codep,ld), Zero); add_lu_cl_info(codep); return 1; } /* count the number of different constants */ static UInt count_consts(GroupDef *grp) { Term current = MkAtomTerm(AtomFoundVar); UInt i = 0; ClauseDef *cl = grp->FirstClause; while (IsAtomTerm(cl->Tag) || IsIntTerm(cl->Tag)) { if (current != cl->Tag) { i++; current = cl->Tag; } if (cl == grp->LastClause) { return i; } cl++; } return i; } /* count the number of different constants */ static UInt count_funcs(GroupDef *grp) { Term current = MkAtomTerm(AtomFoundVar); UInt i = 0; ClauseDef *cl = grp->FirstClause; while (IsApplTerm(cl->Tag)) { if (current != cl->Tag) { i++; current = cl->Tag; } if (cl == grp->LastClause) { return i; } cl++; } return i; } static UInt emit_single_switch_case(ClauseDef *min, PredEntry *ap, int first, int clleft, UInt nxtlbl) { return (UInt)(min->CurrentCode); } static UInt do_var_entries(GroupDef *grp, PredEntry *ap, UInt argno, int first, int clleft, UInt nxtlbl){ if (argno == 1) { /* in this case we want really to jump to the first clause */ if (ap->PredFlags & LogUpdatePredFlag) { if (first && clleft == 0) { return log_update_chain(ap); } else { /* 1 is label for log_update_chain, which should never be taken */ return 1; } } else { if (first && clleft == 0) { /* not protected by a choice-point */ return (UInt)PREVOP(grp->FirstClause->Code,ld); } else { /* this code should never execute */ return nxtlbl; } } } else { UInt labl = new_label(); do_var_group(grp, ap, labl, FALSE, first, clleft, nxtlbl); return labl; } } static UInt do_consts(GroupDef *grp, PredEntry *ap, UInt argno, int first, UInt nxtlbl, int clleft, CELL *top) { UInt n; ClauseDef *min = grp->FirstClause; UInt i; UInt lbl; /* generate a switch */ AtomSwiEntry *cs; if (!IsAtomTerm(min->Tag) && !IsIntTerm(min->Tag)) { /* no clauses, just skip */ return nxtlbl; } n = count_consts(grp); lbl = new_label(); Yap_emit(label_op, lbl, Zero); cs = emit_cswitch(n, nxtlbl); for (i = 0; i < n; i++) { AtomSwiEntry *ics; ClauseDef *max = min; ics = fetch_centry(cs, min->Tag, i, n); ics->Tag = min->Tag; while ((max+1)->Tag == min->Tag && max != grp->LastClause) max++; ics->Label = do_index(min, max, ap, argno+1, nxtlbl, first, clleft, top); grp->FirstClause = min = max+1; } return lbl; } static UInt do_funcs(GroupDef *grp, PredEntry *ap, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { UInt n = count_funcs(grp); ClauseDef *min = grp->FirstClause; UInt i; FuncSwiEntry *fs; UInt lbl; if (min > grp->LastClause || !IsApplTerm(min->Tag)) { /* no clauses, just skip */ return nxtlbl; } lbl = new_label(); Yap_emit(label_op, lbl, Zero); /* generate a switch */ fs = emit_fswitch(n, nxtlbl); for (i = 0; i < n ; i++) { Functor f = (Functor)RepAppl(min->Tag); FuncSwiEntry *ifs; ClauseDef *max = min; ifs = fetch_fentry(fs, f, i, n); ifs->Tag = f; while ((max+1)->Tag == min->Tag && max != grp->LastClause) max++; if (IsExtensionFunctor(f)) { ifs->Label = do_index(min, max, ap, argno+1, nxtlbl, first, clleft, top); } else { ifs->Label = do_compound_index(min, max, ap, ArityOfFunctor(f), argno+1, nxtlbl, first, last_arg, clleft, top); } grp->FirstClause = min = max+1; } return lbl; } static UInt do_pair(GroupDef *grp, PredEntry *ap, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { ClauseDef *min = grp->FirstClause; ClauseDef *max = grp->LastClause; if (min > max) { /* no clauses, just skip */ return nxtlbl; } else if (min == max) { /* single clause, no need to do indexing, but we do know it is a list */ return (UInt)(min->CurrentCode); } return do_compound_index(min, max, ap, 2, argno+1, nxtlbl, first, last_arg, clleft, top); } static void group_prologue(int compound_term, UInt argno, int first) { if (compound_term) { Yap_emit(cache_sub_arg_op, compound_term-1, compound_term-1); } else { if (!first || argno != 1) { Yap_emit(cache_arg_op, argno, argno); } } } /* make sure that we can handle failure correctly */ static void emit_protection_choicepoint(int first, int clleft, UInt nxtlbl) { if (first) { if (clleft) { Yap_emit(tryme_op, nxtlbl, (clleft << 1)); } } else { /* !first */ if (clleft) { Yap_emit(retryme_op, nxtlbl, (clleft << 1)); } else { Yap_emit(trustme_op, 0, 0); } } } static ClauseDef * cls_move(ClauseDef *min, ClauseDef *max, int compound_term, UInt argno, int last_arg) { ClauseDef *cl=min; cl = min; if (compound_term) { while (cl <= max) { skip_to_arg(cl, compound_term, last_arg ); cl++; } } else { while (cl <= max) { if (cl->Tag == (_var+1)*sizeof(CELL)) { ClauseDef *cli = cl; while (cli < max) { clcpy(cli,cli+1); cli++; } max--; } else { move_next(cl, argno); } cl++; } } return max; } static void purge_pvar(GroupDef *group) { ClauseDef *max = group->LastClause; ClauseDef *cl = group->FirstClause; while (cl <= max) { if (cl->Tag == (_var+1)*sizeof(CELL)) { ClauseDef *cli = cl; while (cli < max) { clcpy(cli,cli+1); cli++; } group->VarClauses--; max--; } cl++; } group->LastClause = max; } static void do_nonvar_group(GroupDef *grp, int compound_term, UInt labl, PredEntry *ap, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { TypeSwitch *type_sw; /* move cl pointer */ if (grp->AtomClauses + grp->PairClauses + grp->StructClauses > 1) { Yap_emit(label_op, labl, Zero); if (argno == 1) { emit_protection_choicepoint(first, clleft, nxtlbl); } group_prologue(compound_term, argno, first); if (grp->LastClause < grp->FirstClause) { /* only tests */ return; } type_sw = emit_type_switch(switch_on_type_op); type_sw->VarEntry = do_var_entries(grp, ap, argno, first, clleft, nxtlbl); grp->LastClause = cls_move(grp->FirstClause, grp->LastClause, compound_term, argno, last_arg); sort_group(grp); type_sw->ConstEntry = do_consts(grp, ap, argno, first, nxtlbl, clleft, top); type_sw->FuncEntry = do_funcs(grp, ap, argno, first, last_arg, nxtlbl, clleft, top); type_sw->PairEntry = do_pair(grp, ap, argno, first, last_arg, nxtlbl, clleft, top); } else { do_var_group(grp, ap, labl, TRUE, first, clleft, nxtlbl); } } static UInt do_optims(GroupDef *group, int ngroups, UInt fail_l) { if (ngroups==2 && group[0].FirstClause == group[0].LastClause && group[0].AtomClauses == 1 && group[1].VarClauses == 1) { CELL *sp; UInt labl; labl = new_label(); sp = Yap_emit_extra_size(if_not_op, Zero, 3*CellSize); sp[0] = (CELL)(group[0].FirstClause->Tag); sp[1] = (CELL)(group[1].FirstClause->Code); sp[2] = (CELL)PREVOP(group[0].FirstClause->Code,ld); return labl; } return fail_l; } static int cls_info(ClauseDef *min, ClauseDef *max, UInt argno) { ClauseDef *cl=min; int found_pvar = FALSE; while (cl <= max) { add_info(cl, argno); if (cl->Tag == (_var+1)*sizeof(CELL)) { found_pvar = TRUE; } /* if (IsVarTerm(cl->Tag)) cl->Tag = (CELL)NULL; */ cl++; } return found_pvar; } static UInt do_index(ClauseDef *min, ClauseDef* max, PredEntry *ap, UInt argno, UInt fail_l, int first, int clleft, CELL *top) { UInt ngroups, found_pvar = FALSE; UInt i = 0; GroupDef *group = (GroupDef *)top; UInt labl, labl0; if (min == max) { /* base case, just commit to the current code */ return emit_single_switch_case(min, ap, first, clleft, fail_l); } if (ap->ArityOfPE < argno) { UInt labl = new_label(); do_var_clauses(min, max, FALSE, ap, labl, first, clleft, fail_l); return labl; } found_pvar = cls_info(min, max, argno); ngroups = groups_in(min, max, group); top = (CELL *)(group+ngroups); labl0 = labl = new_label(); if (argno >1) { /* don't try being smart for other arguments than the first */ if (ngroups > 1 || group->VarClauses != 0 || found_pvar) { if (ap->KindOfPE == argno) { labl = new_label(); do_var_clauses(min, max, FALSE, ap, labl, first, clleft, fail_l); return labl; } else { return do_index(min, max, ap, argno+1, fail_l, first, clleft, top); } } else { ClauseDef *cl = min; /* need to reset the code pointer, otherwise I could be in the middle of a compound term. */ while (cl <= max) { cl->CurrentCode = cl->Code; cl++; } } } else { UInt special_options; if ((special_options = do_optims(group, ngroups, fail_l)) != fail_l) { return special_options; } if (ap->PredFlags & LogUpdatePredFlag) { /* complicated stuff */ if (ngroups == 1 && group->VarClauses) { return log_update_chain(ap); } else if (ngroups > 1) { TypeSwitch *type_sw; Yap_emit(label_op, labl0, Zero); /* first group has variables */ type_sw = emit_type_switch(switch_on_type_op); type_sw->VarEntry = log_update_chain(ap); labl = new_label(); type_sw->ConstEntry = type_sw->FuncEntry = type_sw->PairEntry = labl; } } else if (ngroups == 1 && group->VarClauses && !found_pvar) { return fail_l; } else if (ngroups > 1 || found_pvar) { Yap_emit(label_op, labl0, Zero); Yap_emit(jump_v_op, (CELL)PREVOP(min->Code,ld), Zero); labl = new_label(); } } for (i=0; i < ngroups; i++) { UInt nextlbl; int left_clauses = clleft+(max-group->LastClause); /* a group may end up not having clauses*/ if (i < ngroups-1) { nextlbl = new_label(); } else { nextlbl = fail_l; } if (found_pvar && argno == 1) { purge_pvar(group); } if (group->FirstClause==group->LastClause && first && left_clauses == 0) { Yap_emit(jumpi_op, (CELL)(group->FirstClause->Code), Zero); } else { if (group->VarClauses) { do_var_group(group, ap, labl, argno == 1, first, left_clauses, nextlbl); } else { do_nonvar_group(group, 0, labl, ap, argno, first, TRUE, nextlbl, left_clauses, top); } } first = FALSE; group++; labl = nextlbl; } return labl0; } /* execute an index inside a structure */ static UInt do_compound_index(ClauseDef *min, ClauseDef* max, PredEntry *ap, UInt arity, UInt argno, UInt fail_l, int first, int last_arg, int clleft, CELL *top) { UInt ngroups; UInt i = 0; GroupDef *group; int labl; ClauseDef *cl = min; if (min == max) { /* base case, just commit to the current code */ return emit_single_switch_case(cl, ap, first, clleft, fail_l); } group = (GroupDef *)top; cl = min; while (i < arity) { ClauseDef *cl = min; /* search for a subargument */ while (cl <= max) { add_arg_info(cl, i+1); cl++; } ngroups = groups_in(min, max, group); if (ngroups == 1 && group->VarClauses == 0) break; i++; } if (i == arity) { return do_index(min, max, ap, argno+1, fail_l, first, clleft, top); } else { last_arg = (last_arg && i+1 == arity); } /* ok, we are doing a sub-argument */ /* process groups */ labl = new_label(); top = (CELL *)(group+1); do_nonvar_group(group, i+1, labl, ap, argno, argno == 1, last_arg, fail_l, clleft, top); return labl; } static void init_clauses(ClauseDef *cl, PredEntry *ap) { yamop *codep = ap->cs.p_code.FirstClause; UInt n = ap->cs.p_code.NOfClauses; while (n > 0) { cl->Code = cl->CurrentCode = NEXTOP(codep,ld); n--; cl++; codep = NextClause(codep); } } static UInt compile_index(PredEntry *ap) { int NClauses = ap->cs.p_code.NOfClauses; ClauseDef *cls = (ClauseDef *)H; CELL *top = (CELL *) TR; /* only global variable I use directly */ labelno = 1; Yap_Error_Size = NClauses*sizeof(ClauseDef); /* reserve double the space for compiler */ if (cls+2*NClauses > (ClauseDef *)(ASP-4096)) { /* tell how much space we need */ Yap_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ longjmp(Yap_CompilerBotch,3); } freep = (char *)(cls+NClauses); CodeStart = cpc = NIL; if (ap->PredFlags & LogUpdatePredFlag) { /* throw away a label */ new_label(); } /* prepare basic data structures */ init_clauses(cls,ap); return do_index(cls, cls+(NClauses-1), ap, 1, (UInt)FAILCODE, TRUE, 0, top); } yamop * Yap_PredIsIndexable(PredEntry *ap) { yamop *indx_out; Yap_Error_Size = 0; if (setjmp(Yap_CompilerBotch) == 3) { restore_machine_regs(); Yap_gcl(Yap_Error_Size, ap->ArityOfPE, ENV, CP); } restart_index: Yap_ErrorMessage = NULL; if (compile_index(ap) == (UInt)FAILCODE) { return NULL; } #ifdef DEBUG if (Yap_Option['i' - 'a' + 1]) { Yap_ShowCode(); } #endif /* globals for assembler */ CurrentPred = ap; IPredArity = ap->ArityOfPE; if ((indx_out = Yap_assemble(ASSEMBLING_INDEX)) == NULL) { if (!Yap_growheap(FALSE, Yap_Error_Size)) { Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage); return NULL; } goto restart_index; } return(indx_out); }