/************************************************************************* * * * 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 * * comments: Indexing a Prolog predicate * * * * Last rev: $Date: 2008-08-07 20:51:21 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ * Revision 1.202 2008/07/11 17:02:07 vsc * fixes by Bart and Tom: mostly libraries but nasty one in indexing * compilation. * * Revision 1.201 2008/05/10 23:24:11 vsc * fix threads and LU * * Revision 1.200 2008/04/16 17:16:47 vsc * make static_clause only commit to a lause if it is sure that is the true * clause. Otherwise, search for the clause. * * Revision 1.199 2008/04/14 21:20:35 vsc * fixed a bug in static_clause (thanks to Jose Santos) * * Revision 1.198 2008/03/25 16:45:53 vsc * make or-parallelism compile again * * Revision 1.197 2008/02/14 14:35:13 vsc * fixes for indexing code. * * Revision 1.196 2008/01/30 10:35:43 vsc * fix indexing in 64 bits (it would split ints from atoms :( ). * * Revision 1.195 2008/01/24 10:20:42 vsc * clause should not try to discover who is fail. * * Revision 1.194 2008/01/24 00:11:59 vsc * garbage collector was not asking for space. * avoid 0 sized calls to mmap. * * Revision 1.193 2008/01/23 17:57:46 vsc * valgrind it! * enable atom garbage collection. * * Revision 1.192 2007/11/26 23:43:08 vsc * fixes to support threads and assert correctly, even if inefficiently. * * Revision 1.191 2007/11/08 15:52:15 vsc * fix some bugs in new dbterm code. * * Revision 1.190 2007/11/07 09:25:27 vsc * speedup meta-calls * * Revision 1.189 2007/11/06 17:02:12 vsc * compile ground terms away. * * Revision 1.188 2007/10/28 11:23:40 vsc * fix overflow * * Revision 1.187 2007/09/22 08:38:05 vsc * nb_ extra stuff plus an indexing overflow fix. * * Revision 1.186 2007/06/20 13:48:45 vsc * fix bug in index emulator * * Revision 1.185 2007/05/02 11:01:37 vsc * get rid of type punning warnings. * * Revision 1.184 2007/03/26 15:18:43 vsc * debugging and clause/3 over tabled predicates would kill YAP. * * Revision 1.183 2007/03/21 23:23:46 vsc * fix excessive trail cleaning in gc tr overflow. * * Revision 1.182 2007/01/28 14:26:36 vsc * WIN32 support * * Revision 1.181 2007/01/08 08:27:19 vsc * fix restore (Trevor) * make indexing a bit faster on IDB * * Revision 1.180 2006/12/27 01:32:37 vsc * diverse fixes * * Revision 1.179 2006/11/27 17:42:02 vsc * support for UNICODE, and other bug fixes. * * Revision 1.178 2006/11/21 16:21:31 vsc * fix I/O mess * fix spy/reconsult mess * * Revision 1.177 2006/11/15 00:13:36 vsc * fixes for indexing code. * * Revision 1.176 2006/11/08 01:53:08 vsc * avoid generating suspensions on static code. * * Revision 1.175 2006/11/06 18:35:04 vsc * 1estranha * * Revision 1.174 2006/10/25 02:31:07 vsc * fix emulation of trust_logical * * Revision 1.173 2006/10/18 13:47:31 vsc * index.c implementation of trust_logical was decrementing the wrong * cp_tr * * Revision 1.172 2006/10/16 17:12:48 vsc * fixes for threaded version. * * Revision 1.171 2006/10/11 14:53:57 vsc * fix memory leak * fix overflow handling * VS: ---------------------------------------------------------------------- * * Revision 1.170 2006/10/10 14:08:16 vsc * small fixes on threaded implementation. * * Revision 1.169 2006/09/20 20:03:51 vsc * improve indexing on floats * fix sending large lists to DB * * Revision 1.168 2006/05/16 18:37:30 vsc * WIN32 fixes * compiler bug fixes * extend interface * * Revision 1.167 2006/05/02 16:44:11 vsc * avoid uninitialised memory at overflow. * * Revision 1.166 2006/05/02 16:39:06 vsc * bug in indexing code * fix warning messages for write.c * * Revision 1.165 2006/04/27 17:04:08 vsc * don't use <= to compare with block top (libc may not have block header). * * Revision 1.164 2006/04/27 14:10:36 rslopes * *** empty log message *** * * Revision 1.163 2006/04/20 15:28:08 vsc * more graph stuff. * * Revision 1.162 2006/04/12 18:56:50 vsc * fix bug in clause: a trust_me followed by a try should be implemented by * reusing the choice-point. * * Revision 1.161 2006/04/05 00:16:54 vsc * Lots of fixes (check logfile for details * * Revision 1.160 2006/03/24 17:13:41 rslopes * New update to BEAM engine. * BEAM now uses YAP Indexing (JITI) * * Revision 1.159 2006/03/22 20:07:28 vsc * take better care of zombies * * Revision 1.158 2006/03/21 21:30:54 vsc * avoid looking around when expanding for statics too. * * Revision 1.157 2006/03/21 19:20:34 vsc * fix fix on index expansion * * Revision 1.156 2006/03/21 17:11:39 vsc * prevent breakage * * Revision 1.155 2006/03/21 15:06:35 vsc * fixes to handle expansion of dyn amic predicates more efficiently. * * Revision 1.154 2006/03/20 19:51:43 vsc * fix indexing and tabling bugs * * Revision 1.153 2006/02/22 11:55:36 vsc * indexing code would get confused about size of float/1, db_reference1. * * Revision 1.152 2006/02/19 02:55:46 vsc * disable indexing on bigints * * Revision 1.151 2006/01/16 02:57:51 vsc * fix bug with very large integers * fix bug where indexing code was looking at code after a cut. * * Revision 1.150 2005/12/23 00:20:13 vsc * updates to gprof * support for __POWER__ * Try to saveregs before siglongjmp. * * Revision 1.149 2005/12/17 03:25:39 vsc * major changes to support online event-based profiling * improve error discovery and restart on scanner. * * Revision 1.148 2005/11/24 15:33:52 tiagosoares * removed some compilation warnings related to the cut-c code * * Revision 1.147 2005/11/18 18:48:52 tiagosoares * support for executing c code when a cut occurs * * Revision 1.146 2005/10/29 02:21:47 vsc * people should be able to disable indexing. * * Revision 1.145 2005/09/08 22:06:44 rslopes * BEAM for YAP update... * * Revision 1.144 2005/08/17 18:48:35 vsc * fix bug in processing overflows of expand_clauses. * * Revision 1.143 2005/08/02 03:09:50 vsc * fix debugger to do well nonsource predicates. * * Revision 1.142 2005/08/01 15:40:37 ricroc * TABLING NEW: better support for incomplete tabling * * Revision 1.141 2005/07/19 16:54:20 rslopes * fix for older compilers... * * Revision 1.140 2005/07/18 17:41:16 vsc * Yap should respect single argument indexing. * * Revision 1.139 2005/07/06 19:33:53 ricroc * TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure. * * Revision 1.138 2005/07/05 18:32:32 vsc * ifix some wierd cases in indexing code: * would not look at next argument * problem with pvar as last clause (R Camacho). * * Revision 1.137 2005/06/04 07:27:34 ricroc * long int support for tabling * * Revision 1.136 2005/06/03 08:26:32 ricroc * float support for tabling * * Revision 1.135 2005/06/01 20:25:23 vsc * == and \= should not need a choice-point in -> * * Revision 1.134 2005/06/01 16:42:30 vsc * put switch_list_nl back * * Revision 1.133 2005/06/01 14:02:50 vsc * get_rid of try_me?, retry_me? and trust_me? instructions: they are not * significantly used nowadays. * * Revision 1.132 2005/05/31 20:04:17 vsc * fix cleanup of expand_clauses: make sure we have everything with NULL afterwards. * * Revision 1.131 2005/05/31 19:42:27 vsc * insert some more slack for indices in LU * Use doubly linked list for LU indices so that updating is less cumbersome. * * Revision 1.130 2005/05/31 04:46:06 vsc * fix expand_index on tabled code. * * Revision 1.129 2005/05/31 02:15:53 vsc * fix SYSTEM_ERROR messages * * Revision 1.128 2005/05/30 05:26:49 vsc * fix tabling * allow atom gc again for now. * * Revision 1.127 2005/05/27 21:44:00 vsc * Don't try to mess with sequences that don't end with a trust. * A fix for the atom garbage collector actually ignore floats ;-). * * Revision 1.126 2005/05/25 18:58:37 vsc * fix another bug in nth_instance, thanks to Pat Caldon * * Revision 1.125 2005/04/28 14:50:45 vsc * clause should always deref before testing type * * Revision 1.124 2005/04/27 20:09:25 vsc * indexing code could get confused with suspension points * some further improvements on oveflow handling * fix paths in Java makefile * changs to support gibbs sampling in CLP(BN) * * Revision 1.123 2005/04/21 13:53:05 vsc * fix bug with (var(X) -> being interpreted as var(X) by indexing code * * Revision 1.122 2005/04/10 04:01:12 vsc * bug fixes, I hope! * * Revision 1.121 2005/04/07 17:48:54 ricroc * Adding tabling support for mixed strategy evaluation (batched and local scheduling) * UPDATE: compilation flags -DTABLING_BATCHED_SCHEDULING and -DTABLING_LOCAL_SCHEDULING removed. To support tabling use -DTABLING in the Makefile or --enable-tabling in configure. * NEW: yap_flag(tabling_mode,MODE) changes the tabling execution mode of all tabled predicates to MODE (batched, local or default). * NEW: tabling_mode(PRED,MODE) changes the default tabling execution mode of predicate PRED to MODE (batched or local). * * Revision 1.120 2005/03/15 18:29:23 vsc * fix GPL * fix idb: stuff in coroutines. * * Revision 1.119 2005/03/04 20:30:12 ricroc * bug fixes for YapTab support * * Revision 1.118 2005/03/01 22:25:08 vsc * fix pruning bug * make DL_MALLOC less enthusiastic about walking through buckets. * * Revision 1.117 2005/02/25 00:09:06 vsc * fix fix, otherwise I'd remove two choice-points :-(. * * Revision 1.116 2005/02/24 21:46:39 vsc * Improve error handling routine, trying to make it more robust. * Improve hole handling in stack expansion * Clause interrpeter was supposed to prune _trust_me * Wrong messages for acos and atanh * * Revision 1.115 2005/02/21 16:50:00 vsc * amd64 fixes * library fixes * * Revision 1.114 2005/01/28 23:14:36 vsc * move to Yap-4.5.7 * Fix clause size * * Revision 1.113 2005/01/15 05:21:36 vsc * fix bug in clause emulator * * Revision 1.112 2004/12/28 22:20:35 vsc * some extra bug fixes for trail overflows: some cannot be recovered that easily, * some can. * * Revision 1.111 2004/12/21 17:17:15 vsc * miscounting of variable-only clauses in groups might lead to bug in indexing * code. * * Revision 1.110 2004/12/06 04:50:22 vsc * fix bug in removing first clause of a try sequence (lu preds) * * Revision 1.109 2004/12/05 05:01:24 vsc * try to reduce overheads when running with goal expansion enabled. * CLPBN fixes * Handle overflows when allocating big clauses properly. * * Revision 1.108 2004/11/19 22:08:42 vsc * replace SYSTEM_ERROR by out OUT_OF_WHATEVER_ERROR whenever appropriate. * * Revision 1.107 2004/11/19 17:14:14 vsc * a few fixes for 64 bit compiling. * * Revision 1.106 2004/11/18 22:32:36 vsc * fix situation where we might assume nonextsing double initialisation of C predicates (use * Hidden Pred Flag). * $host_type was double initialised. * * Revision 1.105 2004/11/04 18:22:32 vsc * don't ever use memory that has been freed (that was done by LU). * generic fixes for WIN32 libraries * * Revision 1.104 2004/10/27 15:56:33 vsc * bug fixes on memory overflows and on clauses :- fail being ignored by clause. * * Revision 1.103 2004/10/22 16:53:19 vsc * bug fixes * * Revision 1.102 2004/10/04 18:56:19 vsc * fixes for thread support * fix indexing bug (serious) * * Revision 1.101 2004/09/30 21:37:41 vsc * fixes for thread support * * Revision 1.100 2004/09/30 19:51:54 vsc * fix overflow from within clause/2 * * Revision 1.99 2004/09/27 20:45:03 vsc * Mega clauses * Fixes to sizeof(expand_clauses) which was being overestimated * Fixes to profiling+indexing * Fixes to reallocation of memory after restoring * Make sure all clauses, even for C, end in _Ystop * Don't reuse space for Streams * Fix Stream_F on StreaNo+1 * * Revision 1.98 2004/09/14 03:30:06 vsc * make sure that condor version always grows trail! * * Revision 1.97 2004/09/03 03:11:09 vsc * memory management fixes * * Revision 1.96 2004/08/27 20:18:52 vsc * more small fixes * * Revision 1.95 2004/08/11 16:14:52 vsc * whole lot of fixes: * - memory leak in indexing * - memory management in WIN32 now supports holes * - extend Yap interface, more support for SWI-Interface * - new predicate mktime in system * - buffer console I/O in WIN32 * * Revision 1.94 2004/07/29 18:15:18 vsc * fix severe bug in indexing of floating point numbers * * Revision 1.93 2004/07/23 19:01:14 vsc * fix bad ref count in expand_clauses when copying indexing block * * Revision 1.92 2004/06/29 19:04:42 vsc * fix multithreaded version * include new version of Ricardo's profiler * new predicat atomic_concat * allow multithreaded-debugging * small fixes * * Revision 1.91 2004/06/17 22:07:23 vsc * bad bug in indexing code. * * Revision 1.90 2004/04/29 03:44:04 vsc * fix bad suspended clause counter * * Revision 1.89 2004/04/27 15:03:43 vsc * more fixes for expand_clauses * * Revision 1.88 2004/04/22 03:24:17 vsc * trust_logical should protect the last clause, otherwise it cannot * jump there. * * Revision 1.87 2004/04/21 04:01:53 vsc * fix bad ordering when inserting second clause * * Revision 1.86 2004/04/20 22:08:23 vsc * fixes for corourining * * Revision 1.85 2004/04/16 19:27:31 vsc * more bug fixes * * Revision 1.84 2004/04/14 19:10:38 vsc * expand_clauses: keep a list of clauses to expand * fix new trail scheme for multi-assignment variables * * Revision 1.83 2004/04/07 22:04:04 vsc * fix memory leaks * * Revision 1.82 2004/03/31 01:02:18 vsc * if number of left-over < 1/5 keep list of clauses to expand around * fix call to stack expander * * Revision 1.81 2004/03/25 02:19:10 pmoura * Removed debugging line to allow compilation. * * Revision 1.80 2004/03/19 11:35:42 vsc * trim_trail for default machine * be more aggressive about try-retry-trust chains. * - handle cases where block starts with a wait * - don't use _killed instructions, just let the thing rot by itself. * * * * *************************************************************************/ #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 "absmi.h" #include "compile.h" #include "index.h" #if DEBUG #include "yapio.h" #endif #ifndef NULL #define NULL (void *)0 #endif #if HAVE_STRING_H #include #endif #include "cut_c.h" #if defined(YAPOR) || defined(THREADS) #define SET_JLBL(X) jlbl = &(ipc->u.X) #else #define SET_JLBL(X) #endif static UInt do_index(ClauseDef *,ClauseDef *,struct intermediates *,UInt,UInt,int,int,CELL *); static UInt do_compound_index(ClauseDef *,ClauseDef *,Term *t,struct intermediates *,UInt,UInt,UInt,UInt,int,int,int,CELL *,int); static UInt do_dbref_index(ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *); static UInt do_blob_index(ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *,int); static UInt cleanup_sw_on_clauses(CELL larg, UInt sz, OPCODE ecls) { if (larg & 1) { return sz; } else { yamop *xp = (yamop *)larg; if (xp->opc == ecls) { if (xp->u.sssllp.s3 == 1) { UInt nsz = sz + (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *); LOCK(ExpandClausesListLock); if (ExpandClausesFirst == xp) ExpandClausesFirst = xp->u.sssllp.snext; if (ExpandClausesLast == xp) { ExpandClausesLast = xp->u.sssllp.sprev; } if (xp->u.sssllp.sprev) { xp->u.sssllp.sprev->u.sssllp.snext = xp->u.sssllp.snext; } if (xp->u.sssllp.snext) { xp->u.sssllp.snext->u.sssllp.sprev = xp->u.sssllp.sprev; } UNLOCK(ExpandClausesListLock); #if DEBUG Yap_ExpandClauses--; Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *); #endif if (xp->u.sssllp.p->PredFlags & LogUpdatePredFlag) { Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+xp->u.sssllp.s1*sizeof(yamop *); } else Yap_IndexSpace_EXT -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *); Yap_FreeCodeSpace((char *)xp); return nsz; } else { xp->u.sssllp.s3--; return sz; } } else { return sz; } } } static UInt recover_from_failed_susp_on_cls(struct intermediates *cint, UInt sz) { /* we have to recover all allocated blocks, just follow the code through. */ struct PSEUDO *cpc = cint->CodeStart; OPCODE ecls = Yap_opcode(_expand_clauses); UInt log_upd_pred = cint->CurrentPred->PredFlags & LogUpdatePredFlag; while (cpc) { switch(cpc->op) { case enter_lu_op: if (cpc->rnd4) { yamop *code_p = (yamop *)cpc->rnd4; yamop *first = code_p->u.Illss.l1; yamop *last = code_p->u.Illss.l2; while (first) { yamop *next = first->u.OtaLl.n; LogUpdClause *cl = first->u.OtaLl.d; cl->ClRefCount--; Yap_FreeCodeSpace((char *)first); if (first == last) break; first = next; } } cpc->rnd4 = Zero; break; case jump_v_op: case jump_nv_op: sz = cleanup_sw_on_clauses(cpc->rnd1, sz, ecls); break; case switch_on_type_op: { TypeSwitch *type_sw = (TypeSwitch *)(cpc->arnds); sz = cleanup_sw_on_clauses(type_sw->PairEntry, sz, ecls); sz = cleanup_sw_on_clauses(type_sw->ConstEntry, sz, ecls); sz = cleanup_sw_on_clauses(type_sw->FuncEntry, sz, ecls); sz = cleanup_sw_on_clauses(type_sw->VarEntry, sz, ecls); } break; case switch_c_op: case if_c_op: { AtomSwiEntry *target = (AtomSwiEntry *)(cpc->rnd2); int cases = cpc->rnd1, i; for (i = 0; i < cases; i++) { sz = cleanup_sw_on_clauses(target[i].u_a.Label, sz, ecls); } if (log_upd_pred) { LogUpdIndex *lcl = ClauseCodeToLogUpdIndex(cpc->rnd2); sz += sizeof(LogUpdIndex)+cases*sizeof(AtomSwiEntry); Yap_LUIndexSpace_SW -= sizeof(LogUpdIndex)+cases*sizeof(AtomSwiEntry); Yap_FreeCodeSpace((char *)lcl); } else { StaticIndex *scl = ClauseCodeToStaticIndex(cpc->rnd2); sz += sizeof(StaticIndex)+cases*sizeof(AtomSwiEntry); Yap_IndexSpace_SW -= sizeof(StaticIndex)+cases*sizeof(AtomSwiEntry); Yap_FreeCodeSpace((char *)scl); } } break; case switch_f_op: case if_f_op: { FuncSwiEntry *target = (FuncSwiEntry *)(cpc->rnd2); int cases = cpc->rnd1, i; for (i = 0; i < cases; i++) { sz = cleanup_sw_on_clauses(target[i].u_f.Label, sz, ecls); } if (log_upd_pred) { LogUpdIndex *lcl = ClauseCodeToLogUpdIndex(cpc->rnd2); sz += sizeof(LogUpdIndex)+cases*sizeof(FuncSwiEntry); Yap_LUIndexSpace_SW -= sizeof(LogUpdIndex)+cases*sizeof(FuncSwiEntry); Yap_FreeCodeSpace((char *)lcl); } else { StaticIndex *scl = ClauseCodeToStaticIndex(cpc->rnd2); Yap_IndexSpace_SW -= sizeof(StaticIndex)+cases*sizeof(FuncSwiEntry); sz += sizeof(StaticIndex)+cases*sizeof(FuncSwiEntry); Yap_FreeCodeSpace((char *)scl); } } break; default: break; } cpc = cpc->nextInst; } Yap_ReleaseCMem(cint); if (cint->code_addr) { Yap_FreeCodeSpace((char *)cint->code_addr); cint->code_addr = NULL; } return sz; } static inline int smaller(Term t1, Term t2) { CELL tg1 = LowTagOf(t1), tg2 = LowTagOf(t2); if (tg1 == tg2) { return t1 < t2; } else return tg1 < tg2; } static inline int smaller_or_eq(Term t1, Term t2) { CELL tg1 = LowTagOf(t1), tg2 = LowTagOf(t2); if (tg1 == tg2) { return t1 <= t2; } else return tg1 < tg2; } static inline void clcpy(ClauseDef *d, ClauseDef *s) { memcpy((void *)d, (void *)s, sizeof(ClauseDef)); } static void insort(ClauseDef base[], CELL *p, CELL *q, int my_p) { CELL *j; if (my_p) { p[1] = p[0]; for (j = p; j < q; j += 2) { Term key; Int off = *j; CELL *i; key = base[off].Tag; i = j+1; /* we are at offset 1 */ while (i > p+1 && smaller(key,base[i[-2]].Tag)) { i[0] = i[-2]; i -= 2; } i[0] = off; } } else { for (j = p+2; j < q; j += 2) { Term key; Int off = *j; CELL *i; key = base[off].Tag; i = j; /* we are at offset 1 */ while (i > p && smaller(key,base[i[-2]].Tag)) { i[0] = i[-2]; i -= 2; } i[0] = off; } } } /* copy to a new list of terms */ static void msort(ClauseDef *base, CELL *pt, Int size, int my_p) { if (size > 2) { Int half_size = size / 2; CELL *pt_left, *pt_right, *end_pt, *end_pt_left; int left_p, right_p; if (size < 50) { insort(base, pt, pt+2*size, my_p); return; } pt_right = pt + half_size*2; left_p = my_p^1; right_p = my_p; msort(base, pt, half_size, left_p); msort(base, pt_right, size-half_size, right_p); /* now implement a simple merge routine */ /* pointer to after the end of the list */ end_pt = pt + 2*size; /* pointer to the element after the last element to the left */ end_pt_left = pt+half_size*2; /* where is left list */ pt_left = pt+left_p; /* where is right list */ pt_right += right_p; /* where is new list */ pt += my_p; /* while there are elements in the left or right vector do compares */ while (pt_left < end_pt_left && pt_right < end_pt) { /* if the element to the left is larger than the one to the right */ if (smaller_or_eq(base[pt_left[0]].Tag, base[pt_right[0]].Tag)) { /* copy the one to the left */ pt[0] = pt_left[0]; /* and avance the two pointers */ pt += 2; pt_left += 2; } else { /* otherwise, copy the one to the right */ pt[0] = pt_right[0]; pt += 2; pt_right += 2; } } /* if any elements were left in the left vector just copy them */ while (pt_left < end_pt_left) { pt[0] = pt_left[0]; pt += 2; pt_left += 2; } /* if any elements were left in the right vector and they are in the wrong place, just copy them */ if (my_p != right_p) { while(pt_right < end_pt) { pt[0] = pt_right[0]; pt += 2; pt_right += 2; } } } else { if (size > 1 && smaller(base[pt[2]].Tag,base[pt[0]].Tag)) { CELL t = pt[2]; pt[2+my_p] = pt[0]; pt[my_p] = t; } else if (my_p) { pt[1] = pt[0]; if (size > 1) pt[3] = pt[2]; } } } static void copy_back(ClauseDef *dest, CELL *pt, int max) { /* first need to say that we had no need to make a copy */ int i; CELL *tmp = pt; for (i=0; i < max; i++) { if (*tmp != i) { ClauseDef cl; int j = i; CELL *pnt = tmp; /* found a chain */ /* make a backup copy */ clcpy(&cl, dest+i); do { /* follow the chain */ int k = *pnt; *pnt = j; /* printf("i=%d, k = %d, j = %d\n",i,j,k); */ if (k == i) { clcpy(dest+j, &cl); break; } else { clcpy(dest+j, dest+k); } pnt = pt+2*k; j = k; } while (TRUE); } /* we don't need to do swap */ tmp += 2; } } /* sort a group of clauses by using their tags */ static void sort_group(GroupDef *grp, CELL *top, struct intermediates *cint) { int max = (grp->LastClause-grp->FirstClause)+1, i; CELL *pt, *base; #if USE_SYSTEM_MALLOC if (!(base = (CELL *)Yap_AllocCodeSpace(2*max*sizeof(CELL)))) { CACHE_REGS save_machine_regs(); LOCAL_Error_Size = 2*max*sizeof(CELL); siglongjmp(cint->CompilerBotch,2); } #else base = top; while (top+2*max > (CELL *)LOCAL_TrailTop) { if (!Yap_growtrail(2*max*CellSize, TRUE)) { LOCAL_Error_Size = 2*max*CellSize; save_machine_regs(); siglongjmp(cint->CompilerBotch,4); return; } } #endif pt = base; /* initialise vector */ for (i=0; i < max; i++) { *pt = i; pt += 2; } #define M_EVEN 0 msort(grp->FirstClause, base, max, M_EVEN); copy_back(grp->FirstClause, base, max); #if USE_SYSTEM_MALLOC Yap_FreeCodeSpace((ADDR)base); #endif } /* add copy to register stack for original reg */ static int init_regcopy(wamreg regs[MAX_REG_COPIES], wamreg copy) { regs[0] = copy; return 1; } /* add copy to register stack for original reg */ static int is_regcopy(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 had overflowed, or it just was not there */ return FALSE; } /* 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[regs_count-1]; return regs_count-1; } i++; } /* this copy had overflowed, or it just was not there */ return regs_count; } /* add copy to register stack for original reg */ static int add_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, Int source, Int copy) { int i = 0; while (i < regs_count) { if (regs[i] == source) { /* we found it, add new element as last element */ if (regs_count == MAX_REG_COPIES) { return regs_count; } regs[regs_count] = copy; return regs_count+1; } i++; } /* be careful: we may overwrite an existing copy */ return delete_regcopy(regs, regs_count, copy); } /* add copy to register stack for original reg */ inline static int link_regcopies(wamreg regs[MAX_REG_COPIES], int regs_count, Int c1, Int c2) { int i; for (i=0; iCurrentCode; #include "findclause.h" } static void add_head_info(ClauseDef *clause, UInt regno) { wamreg iarg = Yap_regnotoreg(regno); yamop *cl = clause->CurrentCode; #include "headclause.h" } 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 _native_me: return; case _p_db_ref_x: case _p_float_x: if (wreg == cl->u.xl.x) { clause->CurrentCode = NEXTOP(cl,xl); } return; case _get_list: if (wreg == cl->u.x.x) { clause->CurrentCode = NEXTOP(cl,x); } return; case _glist_valx: case _gl_void_vary: case _gl_void_valy: case _gl_void_varx: case _gl_void_valx: case _glist_valy: return; case _get_atom: if (wreg == cl->u.xc.x) { clause->CurrentCode = NEXTOP(cl,xc); } return; case _get_2atoms: return; case _get_3atoms: return; case _get_4atoms: return; case _get_5atoms: return; case _get_6atoms: return; /* matching is not guaranteed: case _get_float: case _get_longint: case _get_bigint: */ case _get_struct: if (wreg == cl->u.xfa.x) { clause->CurrentCode = NEXTOP(cl,xfa); } default: clause->CurrentCode = clause->Code; return; } } static void add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno) { yamop *cl; if (ap->ModuleOfPred == IDB_MODULE) { cl = clause->Code; } else { cl = clause->ucd.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 = 2; cl = NEXTOP(cl,yx); 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); clause->ucd.WorkPC = NEXTOP(cl,o); 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_float_write: case _unify_l_float_write: cl = NEXTOP(cl,od); break; case _unify_float: case _unify_l_float: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorDouble); clause->ucd.t_ptr = AbsAppl(cl->u.od.d); return; } cl = NEXTOP(cl,od); argno--; break; case _unify_longint: case _unify_l_longint: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorLongInt); clause->ucd.t_ptr = AbsAppl(cl->u.oi.i); return; } argno--; cl = NEXTOP(cl,oi); break; case _unify_bigint: case _unify_l_bigint: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorBigInt); clause->ucd.t_ptr = cl->u.oc.c; return; } cl = NEXTOP(cl,oc); argno--; break; case _unify_string: case _unify_l_string: if (argno == 1) { clause->Tag = AbsAppl((CELL *)FunctorString); clause->ucd.t_ptr = cl->u.ou.u; return; } cl = NEXTOP(cl,ou); argno--; break; 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.ofa.f); clause->ucd.WorkPC = NEXTOP(cl,ofa); return; } /* must skip next n arguments */ argno += cl->u.ofa.a-1; case _unify_l_struc_write: case _unify_struct_write: cl = NEXTOP(cl,ofa); break; case _pop: cl = NEXTOP(cl,e); break; case _pop_n: cl = NEXTOP(cl,s); break; #ifdef BEAM case _run_eam: cl = NEXTOP(cl,os); break; #endif case _get_dbterm: cl = NEXTOP(cl,xc); break; case _unify_dbterm: case _unify_l_dbterm: cl = NEXTOP(cl,oc); break; case _unify_idb_term: case _copy_idb_term: { Term t = clause->ucd.c_sreg[argno]; if (IsVarTerm(t)) { clause->Tag = (CELL)NULL; } else if (IsApplTerm(t)) { CELL *pt = RepAppl(t); clause->Tag = AbsAppl((CELL *)pt[0]); if (IsExtensionFunctor(FunctorOfTerm(t))) { clause->ucd.t_ptr = t; } else { clause->ucd.c_sreg = pt; } } else if (IsPairTerm(t)) { CELL *pt = RepPair(t); clause->Tag = AbsPair(NULL); clause->ucd.c_sreg = pt-1; } else { clause->Tag = t; } } return; default: return; } } } static void skip_to_arg(ClauseDef *clause, PredEntry *ap, UInt argno, int at_point) { yamop *cl; int done = FALSE; if (ap->ModuleOfPred == IDB_MODULE) { return; } else { cl = clause->CurrentCode; } if (!at_point) { clause->CurrentCode = clause->Code; return; } while (!done) { op_numbers op = Yap_op_from_opcode(cl->opc); switch (op) { #ifdef BEAM case _run_eam: clause->CurrentCode = clause->Code; return; #endif case _unify_void: if (argno == 1) { clause->CurrentCode = clause->Code; return; } else { argno--; } case _unify_void_write: cl = NEXTOP(cl,o); break; case _unify_list: case _unify_l_list: case _unify_atom: case _unify_l_atom: /* unification is not guaranteed case _unify_longint: case _unify_l_longint: case _unify_bigint: case _unify_l_bigint: case _unify_l_float: */ case _unify_struct: case _unify_l_struc: if (cl == clause->ucd.WorkPC) { clause->CurrentCode = cl; } else { clause->CurrentCode = clause->Code; } return; 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->CurrentCode = clause->Code; return; } 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_write: case _unify_l_atom_write: cl = NEXTOP(cl,oc); break; case _unify_float_write: case _unify_l_float_write: cl = NEXTOP(cl,od); break; case _unify_l_struc_write: case _unify_struct_write: cl = NEXTOP(cl,ofa); break; case _pop: cl = NEXTOP(cl,e); break; case _pop_n: cl = NEXTOP(cl,s); break; default: clause->CurrentCode = clause->Code; return; } } } static UInt groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *cint) { CACHE_REGS 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; } if (clp->Tag != (_var+1)*sizeof(CELL)) grp->VarClauses++; clp++; } 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++; if (min < max) goto restart_loop; } grp->LastClause = min-1; } groups++; grp++; while (grp+16 > (GroupDef *)LOCAL_TrailTop) { UInt sz = (groups+16)*sizeof(GroupDef); #if USE_SYSTEM_MALLOC LOCAL_Error_Size = sz; /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,4); #else if (!Yap_growtrail(sz, TRUE)) { LOCAL_Error_Size = sz; save_machine_regs(); siglongjmp(cint->CompilerBotch,4); return 0; } #endif } } return groups; } static UInt new_label(struct intermediates *cint) { UInt lbl = cint->i_labelno; cint->i_labelno += 2; return lbl; } static Int has_cut(yamop *pc, PredEntry *ap) { if (ap->PredFlags & LogUpdatePredFlag) { LogUpdClause *lcl = ClauseCodeToLogUpdClause(pc); return ( (lcl->ClFlags & HasCutMask) != 0); } else if (ap->PredFlags & MegaClausePredFlag) { /* must be a fact */ return FALSE; } else { StaticClause *scl; scl = ClauseCodeToStaticClause(pc); return ( (scl->ClFlags & HasCutMask) != 0); } } static void emit_trust(ClauseDef *cl, struct intermediates *cint, UInt nxtlbl, int clauses) { PredEntry *ap = cint->CurrentPred; yamop *clcode = cl->Code; if (ap->PredFlags & TabledPredFlag) clcode = NEXTOP(clcode,Otapl); if (!(ap->PredFlags & LogUpdatePredFlag)) { /* this should not be generated for logical update predicates!! */ if (ap->PredFlags & ProfiledPredFlag) { Yap_emit(retry_profiled_op, Unsigned(ap), Zero, cint); } if (ap->PredFlags & CountPredFlag) { Yap_emit(count_retry_op, Unsigned(ap), Zero, cint); } } if (clauses == 0) { Yap_emit(trust_op, (CELL)clcode, has_cut(cl->Code, ap) , cint); } else { Yap_emit(retry_op, (CELL)clcode, (clauses << 1) | has_cut(cl->Code, ap) , cint); Yap_emit(jumpi_op, nxtlbl, Zero, cint); } } static void emit_retry(ClauseDef *cl, struct intermediates *cint, int clauses) { PredEntry *ap = cint->CurrentPred; yamop *clcode = cl->Code; if (ap->PredFlags & TabledPredFlag) clcode = NEXTOP(clcode,Otapl); if (!(ap->PredFlags & LogUpdatePredFlag)) { /* this should not be generated for logical update predicates!! */ if (ap->PredFlags & ProfiledPredFlag) { Yap_emit(retry_profiled_op, Unsigned(ap), Zero, cint); } if (ap->PredFlags & CountPredFlag) { Yap_emit(count_retry_op, Unsigned(ap), Zero, cint); } } Yap_emit(retry_op, (CELL)clcode, (clauses << 1) | has_cut(cl->Code, ap), cint); } static compiler_vm_op emit_optry(int var_group, int first, int clauses, int clleft, PredEntry *ap) { /* var group */ if (var_group || clauses == 0) { if (first) { return try_op; } else if (clleft+clauses) { return retry_op; } else { return trust_op; } } else if (clleft == 0) { #ifdef TABLING if (ap->PredFlags & TabledPredFlag && !first) { /* we never actually get to remove the last choice-point in this case */ return retry_op; } else #endif /* TABLING */ { /* last group */ return try_op; } } else { /* nonvar group */ return try_in_op; } } static void emit_try(ClauseDef *cl, struct intermediates *cint, int var_group, int first, int clauses, int clleft, UInt nxtlbl) { PredEntry *ap = cint->CurrentPred; yamop *clcode; compiler_vm_op comp_op; if (ap->PredFlags & LogUpdatePredFlag) { clcode = cl->Code; } else if (ap->PredFlags & TabledPredFlag) { clcode = NEXTOP(cl->Code,Otapl); } else { clcode = cl->CurrentCode; } comp_op = emit_optry(var_group, first, clauses, clleft, cint->CurrentPred); Yap_emit(comp_op, (CELL)clcode, ((clauses+clleft) << 1) | has_cut(cl->Code, ap), cint); } static TypeSwitch * emit_type_switch(compiler_vm_op op, struct intermediates *cint) { return (TypeSwitch *)Yap_emit_extra_size(op, 0, sizeof(TypeSwitch), cint); } static yamop * emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_mask) { CACHE_REGS PredEntry *ap = cint->CurrentPred; if (ap->PredFlags & LogUpdatePredFlag) { UInt sz = sizeof(LogUpdIndex)+n*item_size; LogUpdIndex *cl = (LogUpdIndex *)Yap_AllocCodeSpace(sz); if (cl == NULL) { LOCAL_Error_Size = sz; /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_SW += sz; cl->ClFlags = SwitchTableMask|LogUpdMask|func_mask; cl->ClSize = sz; cl->ClPred = cint->CurrentPred; /* insert into code chain */ Yap_inform_profiler_of_clause(cl, (CODEADDR)cl+sz, ap, GPROF_NEW_LU_SWITCH); return cl->ClCode; } else { UInt sz = sizeof(StaticIndex)+n*item_size; StaticIndex *cl = (StaticIndex *)Yap_AllocCodeSpace(sz); if (cl == NULL) { LOCAL_Error_Size = sz; /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } Yap_IndexSpace_SW += sz; cl->ClFlags = SwitchTableMask; cl->ClSize = sz; cl->ClPred = cint->CurrentPred; Yap_inform_profiler_of_clause(cl, (CODEADDR)cl+sz, ap, GPROF_NEW_STATIC_SWITCH); return cl->ClCode; /* insert into code chain */ } } static AtomSwiEntry * emit_cswitch(COUNT n, yamop *fail_l, struct intermediates *cint) { compiler_vm_op op; AtomSwiEntry *target; if (n > MIN_HASH_ENTRIES) { COUNT cases = MIN_HASH_ENTRIES, i; n += 1+n/4; while (cases < n) cases *= 2; n = cases; op = switch_c_op; target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint, 0); for (i=0; i> HASH_SHIFT) & (entries-1); centry = cebase + hash; d = (entries-1) & (t|1); while (centry->Tag != t) { if (centry->Tag == 0L) return centry; hash = (hash + d) & (entries-1); centry = cebase + hash; } return centry; } static AtomSwiEntry * fetch_centry(AtomSwiEntry *cebase, Term wt, int i, int n) { if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES; n += 1+n/4; while (cases < n) cases *= 2; return lookup_c_hash(wt, (yamop *)cebase, cases); } else { return cebase + i; } } static FuncSwiEntry * emit_fswitch(COUNT n, yamop *fail_l, struct intermediates *cint) { compiler_vm_op op; FuncSwiEntry *target; if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, i; n += 1+n/4; while (cases < n) cases *= 2; n = cases; op = switch_f_op; target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint, FuncSwitchMask); for (i=0; i> HASH_SHIFT) & (entries-1); fentry = febase + hash; d = (entries-1) & (wt|1); while (fentry->Tag != f) { if (fentry->Tag == NULL) return fentry; hash = (hash + d) & (entries-1); fentry = febase + hash; } return fentry; } static FuncSwiEntry * fetch_fentry(FuncSwiEntry *febase, Functor ft, int i, int n) { if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES; n += 1+n/4; while (cases < n) cases *= 2; return lookup_f_hash(ft, (yamop *)febase, cases); } else { return febase + i; } } /* we assume there is at least one clause, that is, c0 < cf */ static UInt do_var_clauses(ClauseDef *c0, ClauseDef *cf, int var_group, struct intermediates *cint, int first, int clleft, UInt nxtlbl, UInt argno0) { UInt labl; UInt labl_dyn0 = 0, labl_dynf = 0; labl = new_label(cint); Yap_emit(label_op, labl, Zero, cint); /* add expand_node if var_group == TRUE (jump on var) || var_group == FALSE (leaf node) */ if (first && cint->CurrentPred->PredFlags & LogUpdatePredFlag) { UInt ncls; labl_dyn0 = new_label(cint); if (clleft) labl_dynf = labl_dyn0; else labl_dynf = new_label(cint); if (clleft == 0) /* trust*/ ncls = (cf-c0)+1; else ncls = 0; Yap_emit_4ops(enter_lu_op, labl_dyn0, labl_dynf, ncls, Zero, cint); Yap_emit(label_op, labl_dyn0, Zero, cint); } if (c0 == cf) { emit_try(c0, cint, var_group, first, 0, clleft, nxtlbl); } else { if (c0 < cf) { emit_try(c0, cint, var_group, first, cf-c0, clleft, nxtlbl); } c0++; while (c0 < cf) { emit_retry(c0, cint, clleft+(cf-c0)); c0++; } if (c0 == cf) { emit_trust(c0, cint, nxtlbl, clleft); if (!clleft && cint->CurrentPred->PredFlags & LogUpdatePredFlag) { Yap_emit(label_op, labl_dynf, Zero, cint); } } } return labl; } static UInt do_var_group(GroupDef *grp, struct intermediates *cint, int var_group, int first, int clleft, UInt nxtlbl, UInt argno0) { return do_var_clauses(grp->FirstClause, grp->LastClause, var_group, cint, first, clleft, nxtlbl, argno0); } /* 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; } static UInt count_blobs(GroupDef *grp) { UInt i = 1; ClauseDef *cl = grp->FirstClause+1; Term current = grp->FirstClause->Tag; while (cl <= grp->LastClause) { if (current != cl->Tag) { i++; current = cl->Tag; } 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, struct intermediates *cint, int first, int clleft, UInt nxtlbl) { if (cint->CurrentPred->PredFlags & TabledPredFlag) { /* with tabling we don't clean trust at the very end of computation. */ if (clleft || !first) { /* if we still have clauses left, means we already created a CP, so I should avoid creating again */ return (UInt)NEXTOP(min->Code,Otapl); } else { return (UInt)min->Code; } } if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) { return (UInt)(min->Code); } else { return (UInt)(min->CurrentCode); } } static UInt suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermediates *cint) { UInt tcls = ap->cs.p_code.NOfClauses; UInt cls = (max-min)+1; if (cint->expand_block && cint->expand_block != (yamop *)(&(ap->cs.p_code.ExpandCode)) && cint->expand_block->u.sssllp.s2 < 2*(max-min)) { cint->expand_block->u.sssllp.s3++; return (UInt)(cint->expand_block); } if (cls < tcls/8) { yamop *ncode; yamop **st; UInt tels; UInt sz; if (ap->PredFlags & LogUpdatePredFlag) { /* give it some slack */ tels = cls + 4; } else { tels = cls; } sz = (UInt)NEXTOP((yamop *)NULL,sssllp)+tels*sizeof(yamop *); if ((ncode = (yamop *)Yap_AllocCodeSpace(sz)) == NULL) { save_machine_regs(); siglongjmp(cint->CompilerBotch, 2); } #if DEBUG Yap_ExpandClauses++; Yap_expand_clauses_sz += sz; #endif if (ap->PredFlags & LogUpdatePredFlag) { Yap_LUIndexSpace_EXT += sz; } else { Yap_IndexSpace_EXT += sz; } Yap_inform_profiler_of_clause(ncode, (CODEADDR)ncode+sz, ap, GPROF_NEW_EXPAND_BLOCK); /* create an expand_block */ ncode->opc = Yap_opcode(_expand_clauses); ncode->u.sssllp.p = ap; ncode->u.sssllp.s1 = tels; ncode->u.sssllp.s2 = cls; ncode->u.sssllp.s3 = 1; st = (yamop **)NEXTOP(ncode,sssllp); while (min <= max) { *st++ = min->Code; min++; } while (cls < tels) { *st++ = NULL; cls++; } LOCK(ExpandClausesListLock); ncode->u.sssllp.snext = ExpandClausesFirst; ncode->u.sssllp.sprev = NULL; if (ExpandClausesFirst) ExpandClausesFirst->u.sssllp.sprev = ncode; ExpandClausesFirst = ncode; if (ExpandClausesLast == NULL) ExpandClausesLast = ncode; UNLOCK(ExpandClausesListLock); return (UInt)ncode; } return (UInt)&(ap->cs.p_code.ExpandCode); } static void recover_ecls_block(yamop *ipc) { ipc->u.sssllp.s3--; if (!ipc->u.sssllp.s3) { LOCK(ExpandClausesListLock); if (ExpandClausesFirst == ipc) ExpandClausesFirst = ipc->u.sssllp.snext; if (ExpandClausesLast == ipc) { ExpandClausesLast = ipc->u.sssllp.sprev; } if (ipc->u.sssllp.sprev) { ipc->u.sssllp.sprev->u.sssllp.snext = ipc->u.sssllp.snext; } if (ipc->u.sssllp.snext) { ipc->u.sssllp.snext->u.sssllp.sprev = ipc->u.sssllp.sprev; } UNLOCK(ExpandClausesListLock); #if DEBUG Yap_ExpandClauses--; Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+ipc->u.sssllp.s1*sizeof(yamop *); #endif /* no dangling pointers for gprof */ Yap_InformOfRemoval(ipc); if (ipc->u.sssllp.p->PredFlags & LogUpdatePredFlag) { Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+ipc->u.sssllp.s1*sizeof(yamop *); } else Yap_IndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+ipc->u.sssllp.s1*sizeof(yamop *); Yap_FreeCodeSpace((char *)ipc); } } static UInt do_var_entries(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int clleft, UInt nxtlbl){ PredEntry *ap = cint->CurrentPred; if (!IsVarTerm(t) || t != 0L) { return suspend_indexing(grp->FirstClause, grp->LastClause, ap, cint); } return do_var_group(grp, cint, FALSE, first, clleft, nxtlbl, ap->ArityOfPE+1); } static UInt do_consts(GroupDef *grp, Term t, struct intermediates *cint, int compound_term, CELL *sreg, UInt arity, int last_arg, UInt argno, int first, UInt nxtlbl, int clleft, CELL *top) { COUNT n; ClauseDef *min = grp->FirstClause; COUNT i; UInt lbl; /* generate a switch */ AtomSwiEntry *cs; PredEntry *ap = cint->CurrentPred; if (!IsAtomTerm(min->Tag) && !IsIntTerm(min->Tag)) { /* no clauses, just skip */ return nxtlbl; } n = count_consts(grp); lbl = new_label(cint); Yap_emit(label_op, lbl, Zero, cint); cs = emit_cswitch(n, FAILCODE, cint); 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 != grp->LastClause && (max+1)->Tag == min->Tag) max++; if (min != max) { if (sreg != NULL) { if (ap->PredFlags & LogUpdatePredFlag && max > min) { ics->u_a.Label = suspend_indexing(min, max, ap, cint); } else { ics->u_a.Label = do_compound_index(min, max, sreg, cint, compound_term, arity, argno, nxtlbl, first, last_arg, clleft, top, TRUE); } } else if (ap->PredFlags & LogUpdatePredFlag) { ics->u_a.Label = suspend_indexing(min, max, cint->CurrentPred, cint); } else { ics->u_a.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top); } } else { ics->u_a.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top); } grp->FirstClause = min = max+1; } return lbl; } static void do_blobs(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, UInt nxtlbl, int clleft, CELL *top) { COUNT n; ClauseDef *min = grp->FirstClause; COUNT i; /* generate a switch */ AtomSwiEntry *cs; PredEntry *ap = cint->CurrentPred; n = count_blobs(grp); cs = emit_cswitch(n, (yamop *)nxtlbl, cint); 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 != grp->LastClause && (max+1)->Tag == min->Tag) max++; if (min != max && (ap->PredFlags & LogUpdatePredFlag)) { ics->u_a.Label = suspend_indexing(min, max, ap, cint); } else { ics->u_a.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top); } grp->FirstClause = min = max+1; } } static UInt do_funcs(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { COUNT n = count_funcs(grp); ClauseDef *min = grp->FirstClause; COUNT i; FuncSwiEntry *fs; UInt lbl; if (min > grp->LastClause || n == 0) { /* no clauses, just skip */ return nxtlbl; } lbl = new_label(cint); Yap_emit(label_op, lbl, Zero, cint); /* generate a switch */ fs = emit_fswitch(n, FAILCODE, cint); 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 != grp->LastClause && (max+1)->Tag == min->Tag) max++; /* delay non-trivial indexing if (min != max && !IsExtensionFunctor(f)) { ifs->u.Label = suspend_indexing(min, max, ap, cint); } else */ if (IsExtensionFunctor(f)) { if (f == FunctorDBRef) ifs->u_f.Label = do_dbref_index(min, max, t, cint, argno, nxtlbl, first, clleft, top); else if (f == FunctorLongInt || f == FunctorBigInt) ifs->u_f.Label = do_blob_index(min, max, t, cint, argno, nxtlbl, first, clleft, top, FALSE); else ifs->u_f.Label = do_blob_index(min, max, t, cint, argno, nxtlbl, first, clleft, top, TRUE); } else { CELL *sreg; if (!IsVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == f) { sreg = RepAppl(t)+1; } else { sreg = NULL; } ifs->u_f.Label = do_compound_index(min, max, sreg, cint, 0, ArityOfFunctor(f), argno, nxtlbl, first, last_arg, clleft, top, TRUE); } grp->FirstClause = min = max+1; } return lbl; } static UInt do_pair(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { ClauseDef *min = grp->FirstClause; ClauseDef *max = grp->FirstClause; while (IsPairTerm(max->Tag) && max != grp->LastClause) { max++; } if (!IsPairTerm(max->Tag)) { max--; } if (min > grp->LastClause) { /* no clauses, just skip */ return nxtlbl; } grp->FirstClause = max+1; if (min == max) { /* single clause, no need to do indexing, but we do know it is a list */ if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) { return (UInt)(min->Code); } else { return (UInt)(min->CurrentCode); } } if (min != max && !IsPairTerm(t)) { return suspend_indexing(min, max, cint->CurrentPred, cint); } return do_compound_index(min, max, (IsPairTerm(t) ? RepPair(t) : NULL), cint, 0, 2, argno, nxtlbl, first, last_arg, clleft, top, TRUE); } static void group_prologue(int compound_term, UInt argno, int first, struct intermediates *cint) { if (compound_term) { Yap_emit(cache_sub_arg_op, compound_term-1, compound_term-1, cint); } else { if (!first || argno != 1) { Yap_emit(cache_arg_op, argno, argno, cint); } } } /* make sure that we can handle failure correctly */ static void emit_protection_choicepoint(int first, int clleft, UInt nxtlbl, struct intermediates *cint) { if (first) { if (clleft) { if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) { UInt labl = new_label(cint); Yap_emit_4ops(enter_lu_op, labl, labl, 0, Zero, cint); Yap_emit(label_op, labl, Zero, cint); } Yap_emit(tryme_op, nxtlbl, (clleft << 1), cint); } } else { /* !first */ if (clleft) { Yap_emit(retryme_op, nxtlbl, (clleft << 1), cint); } else { Yap_emit(trustme_op, 0, 0, cint); } } } static ClauseDef * cls_move(ClauseDef *min, PredEntry *ap, 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, ap, 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 UInt * do_nonvar_group(GroupDef *grp, Term t, UInt compound_term, CELL *sreg, UInt arity, UInt labl, struct intermediates *cint, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top) { TypeSwitch *type_sw; PredEntry *ap = cint->CurrentPred; /* move cl pointer */ if (grp->AtomClauses + grp->PairClauses + grp->StructClauses > 1) { Yap_emit(label_op, labl, Zero, cint); if (argno == 1 && !compound_term) { emit_protection_choicepoint(first, clleft, nxtlbl, cint); } group_prologue(compound_term, argno, first, cint); if (grp->LastClause < grp->FirstClause) { /* only tests */ return NULL; } type_sw = emit_type_switch(switch_on_type_op, cint); /* have these first so that we will have something initialised here */ type_sw->ConstEntry = type_sw->FuncEntry = type_sw->PairEntry = type_sw->VarEntry = nxtlbl; type_sw->VarEntry = do_var_entries(grp, t, cint, argno, first, clleft, nxtlbl); grp->LastClause = cls_move(grp->FirstClause, ap, grp->LastClause, compound_term, argno, last_arg); sort_group(grp,top,cint); while (grp->FirstClause <= grp->LastClause) { if (IsAtomOrIntTerm(grp->FirstClause->Tag)) { type_sw->ConstEntry = do_consts(grp, t, cint, compound_term, sreg, arity, last_arg, argno, first, nxtlbl, clleft, top); } else if (IsApplTerm(grp->FirstClause->Tag)) { type_sw->FuncEntry = do_funcs(grp, t, cint, argno, first, last_arg, nxtlbl, clleft, top); } else { type_sw->PairEntry = do_pair(grp, t, cint, argno, first, last_arg, nxtlbl, clleft, top); } } return &(type_sw->VarEntry); } else { Yap_emit(label_op,labl,Zero, cint); do_var_group(grp, cint, TRUE, first, clleft, nxtlbl, ap->ArityOfPE+1); return NULL; } } static UInt do_optims(GroupDef *group, int ngroups, UInt fail_l, ClauseDef *min, struct intermediates *cint) { if (ngroups==2 && group[0].FirstClause == group[0].LastClause && group[0].AtomClauses == 1 && group[1].VarClauses == 1) { CELL *sp; UInt labl; labl = new_label(cint); sp = Yap_emit_extra_size(if_not_op, Zero, 4*CellSize, cint); sp[0] = (CELL)(group[0].FirstClause->Tag); sp[1] = (CELL)(group[1].FirstClause->Code); sp[2] = do_var_clauses(group[0].FirstClause, group[1].LastClause, FALSE, cint, TRUE, 0, (CELL)FAILCODE, cint->CurrentPred->ArityOfPE+1); sp[3] = do_var_clauses(min, group[1].LastClause, FALSE, cint, TRUE, 0, (CELL)FAILCODE, cint->CurrentPred->ArityOfPE+1); 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 int cls_head_info(ClauseDef *min, ClauseDef *max, UInt argno, int in_idb) { ClauseDef *cl=min; if (in_idb) { if (argno != 2) { while (cl <= max) { cl->Tag = (CELL)NULL; cl++; } } else { while (cl <= max) { LogUpdClause *lcl = ClauseCodeToLogUpdClause(cl->CurrentCode); Term t = lcl->lusl.ClSource->Entry; if (IsVarTerm(t)) { cl->Tag = (CELL)NULL; } else if (IsApplTerm(t)) { CELL *pt = RepAppl(t); cl->Tag = AbsAppl((CELL *)pt[0]); if (IsExtensionFunctor(FunctorOfTerm(t))) { cl->ucd.t_ptr = t; } else { cl->ucd.c_sreg = pt; } } else if (IsPairTerm(t)) { CELL *pt = RepPair(t); cl->Tag = AbsPair(NULL); cl->ucd.c_sreg = pt-1; } else { cl->Tag = t; } cl++; } } } else { while (cl <= max) { add_info(cl, argno); /* if (IsVarTerm(cl->Tag)) cl->Tag = (CELL)NULL; */ cl++; } } return FALSE; } static UInt do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno, UInt fail_l, int first, int clleft, CELL *top) { CACHE_REGS UInt ngroups, found_pvar = FALSE; UInt i = 0; GroupDef *group = (GroupDef *)top; UInt labl, labl0, lablx; Term t; /* remember how we entered here */ UInt argno0 = argno; PredEntry *ap = cint->CurrentPred; yamop *eblk = cint->expand_block; if (min == max) { /* base case, just commit to the current code */ return emit_single_switch_case(min, cint, first, clleft, fail_l); } if ((argno > 1 && yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE && ap->PredFlags & LogUpdatePredFlag) || yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_OFF || ap->ArityOfPE < argno) { return do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1); } t = Deref(XREGS[argno]); if (ap->PredFlags & LogUpdatePredFlag) { found_pvar = cls_head_info(min, max, argno, (ap->ModuleOfPred == IDB_MODULE)); } else { found_pvar = cls_info(min, max, argno); } ngroups = groups_in(min, max, group, cint); if (IsVarTerm(t)) { lablx = new_label(cint); Yap_emit(label_op, lablx, Zero, cint); while (IsVarTerm(t)) { if (ngroups > 1 || !group->VarClauses) { UInt susp_lab = suspend_indexing(min, max, ap, cint); if (!cint->expand_block) { cint->expand_block = (yamop *)susp_lab; } Yap_emit(jump_nv_op, susp_lab, argno, cint); } if (argno == ap->ArityOfPE || (yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE && ap->PredFlags & LogUpdatePredFlag)) { do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, argno0); cint->expand_block = eblk; return lablx; } argno++; t = Deref(XREGS[argno]); if (ap->PredFlags & LogUpdatePredFlag) { found_pvar = cls_head_info(min, max, argno, (ap->ModuleOfPred == IDB_MODULE) ); } else { found_pvar = cls_info(min, max, argno); } ngroups = groups_in(min, max, group, cint); } labl0 = labl = new_label(cint); } else { lablx = labl0 = labl = new_label(cint); } cint->expand_block = eblk; top = (CELL *)(group+ngroups); if (argno > 1) { /* don't try being smart for other arguments than the first */ if (ngroups > 1 || group->VarClauses != 0 || found_pvar) { if (ap->ArityOfPE == argno) { return do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1); } else { return do_index(min, max, cint, 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 ((ap->PredFlags & LogUpdatePredFlag) && ngroups > 1) { if (ngroups > 1) { group[0].VarClauses = ap->cs.p_code.NOfClauses; group[0].AtomClauses = group[0].PairClauses = group[0].StructClauses = group[0].TestClauses = 0; group[0].LastClause = group[ngroups-1].LastClause; ngroups = 1; } } else if ((special_options = do_optims(group, ngroups, fail_l, min, cint)) != fail_l) { return special_options; } if (ngroups == 1 && group->VarClauses && !found_pvar) { return do_index(min, max, cint, argno+1, fail_l, first, clleft, top); } else if (found_pvar || (ap->PredFlags & LogUpdatePredFlag && group[0].VarClauses)) { /* make sure we know where to suspend */ Yap_emit(label_op, labl0, Zero, cint); labl = new_label(cint); Yap_emit(jump_v_op, suspend_indexing(min, max, ap, cint), Zero, cint); } } 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(cint); } 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, cint); } else { if (group->VarClauses) { Yap_emit(label_op,labl,Zero, cint); do_var_group(group, cint, argno == 1, first, left_clauses, nextlbl, ap->ArityOfPE+1); } else { do_nonvar_group(group, t, 0, NULL, 0, labl, cint, argno, first, TRUE, nextlbl, left_clauses, top); } } first = FALSE; group++; labl = nextlbl; } return lablx; } static ClauseDef * copy_clauses(ClauseDef *max0, ClauseDef *min0, CELL *top, struct intermediates *cint) { CACHE_REGS UInt sz = ((max0+1)-min0)*sizeof(ClauseDef); if ((char *)top + sz >= LOCAL_TrailTop-4096) { LOCAL_Error_Size = sz; /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,4); } memcpy((void *)top, (void *)min0, sz); return (ClauseDef *)top; } /* make sure that it is worth it to generate indexing code at that point */ static int several_tags(ClauseDef *min, ClauseDef *max) { CELL tag = min->Tag; while (min < max) { min++; if (!IsAtomOrIntTerm(min->Tag) || min->Tag != tag) return TRUE; } return FALSE; } /* execute an index inside a structure */ static UInt do_compound_index(ClauseDef *min0, ClauseDef* max0, Term* sreg, struct intermediates *cint, UInt i, UInt arity, UInt argno, UInt fail_l, int first, int last_arg, int clleft, CELL *top, int done_work) { UInt ret_lab = 0, *newlabp; CELL *top0 = top; ClauseDef *min, *max; PredEntry *ap = cint->CurrentPred; int found_index = FALSE, lu_pred = ap->PredFlags & LogUpdatePredFlag; UInt old_last_depth, old_last_depth_size; newlabp = & ret_lab; if (min0 == max0) { /* base case, just commit to the current code */ return emit_single_switch_case(min0, cint, first, clleft, fail_l); } if ((yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE && ap->PredFlags & LogUpdatePredFlag) || (yap_flags[INDEXING_TERM_DEPTH_FLAG] && cint->term_depth - cint->last_index_new_depth > yap_flags[INDEXING_TERM_DEPTH_FLAG])) { *newlabp = do_var_clauses(min0, max0, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1); return ret_lab; } if (sreg == NULL) { return suspend_indexing(min0, max0, ap, cint); } cint->term_depth++; old_last_depth = cint->last_index_new_depth; old_last_depth_size = cint->last_depth_size; if (cint->last_depth_size != max0-min0) { cint->last_index_new_depth = cint->term_depth; cint->last_depth_size = max0-min0; } while (i < arity && !found_index) { ClauseDef *cl; GroupDef *group; UInt ngroups; int isvt = IsVarTerm(Deref(sreg[i])); min = copy_clauses(max0, min0, top, cint); max = min+(max0-min0); top = (CELL *)(max+1); cl = min; /* search for a subargument */ while (cl <= max) { add_arg_info(cl, ap, i+1); cl++; } group = (GroupDef *)top; ngroups = groups_in(min, max, group, cint); if (ngroups == 1 && group->VarClauses == 0 && (i < 8 || several_tags(min,max))) { /* ok, we are doing a sub-argument */ /* process group */ found_index = TRUE; ret_lab = new_label(cint); top = (CELL *)(group+1); if (do_nonvar_group(group, (sreg == NULL ? 0L : Deref(sreg[i])), i+1, (isvt ? NULL : sreg), arity, *newlabp, cint, argno, first, (last_arg && i+1 == arity), fail_l, clleft, top) == NULL) { top = top0; break; } } top = top0; i++; } if (!found_index) { if (!lu_pred || !done_work) *newlabp = do_index(min0, max0, cint, argno+1, fail_l, first, clleft, top); else *newlabp = suspend_indexing(min0, max0, ap, cint); } cint->last_index_new_depth = old_last_depth; cint->last_depth_size = old_last_depth_size; cint->term_depth--; return ret_lab; } static UInt do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint, UInt argno, UInt fail_l, int first, int clleft, CELL *top) { UInt ngroups; GroupDef *group; ClauseDef *cl = min; group = (GroupDef *)top; cl = min; while (cl <= max) { cl->Tag = cl->ucd.t_ptr; cl++; } ngroups = groups_in(min, max, group, cint); if (ngroups > 1 || group->VarClauses) { return do_index(min, max, cint, argno+1, fail_l, first, clleft, top); } else { int labl = new_label(cint); Yap_emit(label_op, labl, Zero, cint); Yap_emit(index_dbref_op, Zero, Zero, cint); sort_group(group,(CELL *)(group+1),cint); do_blobs(group, t, cint, argno, first, fail_l, clleft, (CELL *)(group+1)); return labl; } } static UInt do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint, UInt argno, UInt fail_l, int first, int clleft, CELL *top, int blob) { UInt ngroups; GroupDef *group; ClauseDef *cl = min; group = (GroupDef *)top; cl = min; while (cl <= max) { if (cl->ucd.t_ptr == (CELL)NULL) { /* check whether it is a builtin */ cl->Tag = Zero; } else if (blob) { cl->Tag = Yap_Double_key(cl->ucd.t_ptr); } else { cl->Tag = Yap_Int_key(cl->ucd.t_ptr); } cl++; } ngroups = groups_in(min, max, group, cint); if (ngroups > 1 || group->VarClauses) { return do_index(min, max, cint, argno+1, fail_l, first, clleft, top); } else { int labl = new_label(cint); Yap_emit(label_op, labl, Zero, cint); if (blob) Yap_emit(index_blob_op, Zero, Zero, cint); else Yap_emit(index_long_op, Zero, Zero, cint); sort_group(group,(CELL *)(group+1),cint); do_blobs(group, t, cint, argno, first, fail_l, clleft, (CELL *)(group+1)); return labl; } } static void init_clauses(ClauseDef *cl, PredEntry *ap) { if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause); UInt nclauses = mcl->ClPred->cs.p_code.NOfClauses; yamop *end = (yamop *)((char *)mcl->ClCode+nclauses*mcl->ClItemSize); yamop *cd = mcl->ClCode; while (cd < end) { cl->Code = cl->CurrentCode = cd; cd = (yamop *)((char *)cd+mcl->ClItemSize); cl++; } } else { StaticClause *scl; scl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause); do { cl->Code = cl->CurrentCode = scl->ClCode; cl++; if (scl->ClCode == ap->cs.p_code.LastClause) return; scl = scl->ClNext; } while (TRUE); } } static void init_log_upd_clauses(ClauseDef *cl, PredEntry *ap) { LogUpdClause *lcl = ClauseCodeToLogUpdClause(ap->cs.p_code.FirstClause); do { cl->Code = cl->CurrentCode = lcl->ClCode; cl++; lcl = lcl->ClNext; } while (lcl != NULL); } static UInt compile_index(struct intermediates *cint) { CACHE_REGS PredEntry *ap = cint->CurrentPred; int NClauses = ap->cs.p_code.NOfClauses; CELL *top = (CELL *) TR; UInt res; /* only global variable I use directly */ cint->i_labelno = 1; LOCAL_Error_Size = 0; #if USE_SYSTEM_MALLOC if (!cint->cls) { cint->cls = (ClauseDef *)Yap_AllocCodeSpace(NClauses*sizeof(ClauseDef)); if (!cint->cls) { /* tell how much space we need */ LOCAL_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } } cint->freep = (char *)HR; #else /* reserve double the space for compiler */ cint->cls = (ClauseDef *)HR; if (cint->cls+2*NClauses > (ClauseDef *)(ASP-4096)) { /* tell how much space we need */ LOCAL_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,3); } cint->freep = (char *)(cint->cls+NClauses); #endif if (ap->PredFlags & LogUpdatePredFlag) { /* throw away a label */ new_label(cint); init_log_upd_clauses(cint->cls,ap); } else if (ap->PredFlags & UDIPredFlag) { UInt lbl = new_label(cint); Yap_emit(user_switch_op, Unsigned(ap), Unsigned(&(ap->cs.p_code.ExpandCode)), cint); return lbl; } else { /* prepare basic data structures */ init_clauses(cint->cls,ap); } res = do_index(cint->cls, cint->cls+(NClauses-1), cint, 1, (UInt)FAILCODE, TRUE, 0, top); return res; } static void CleanCls(struct intermediates *cint) { #if USE_SYSTEM_MALLOC if (cint->cls) { Yap_FreeCodeSpace((ADDR)cint->cls); } #endif cint->cls = NULL; } yamop * Yap_PredIsIndexable(PredEntry *ap, UInt NSlots, yamop *next_pc) { CACHE_REGS yamop *indx_out; int setjres; struct intermediates cint; cint.CurrentPred = ap; cint.code_addr = NULL; cint.blks = NULL; cint.cls = NULL; LOCAL_Error_Size = 0; if ((setjres = sigsetjmp(cint.CompilerBotch, 0)) == 3) { restore_machine_regs(); recover_from_failed_susp_on_cls(&cint, 0); if (!Yap_gcl(LOCAL_Error_Size, ap->ArityOfPE+NSlots, ENV, next_pc)) { CleanCls(&cint); Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); return FAILCODE; } } else if (setjres == 2) { restore_machine_regs(); LOCAL_Error_Size = recover_from_failed_susp_on_cls(&cint, LOCAL_Error_Size); if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) { CleanCls(&cint); Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); return FAILCODE; } } else if (setjres == 4) { restore_machine_regs(); recover_from_failed_susp_on_cls(&cint, 0); if (!Yap_growtrail(LOCAL_Error_Size, FALSE)) { CleanCls(&cint); Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, LOCAL_ErrorMessage); return FAILCODE; } } else if (setjres != 0) { restore_machine_regs(); recover_from_failed_susp_on_cls(&cint, 0); if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); CleanCls(&cint); return FAILCODE; } } restart_index: Yap_BuildMegaClause(ap); cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NULL; cint.expand_block = NULL; cint.label_offset = NULL; LOCAL_ErrorMessage = NULL; cint.term_depth = cint.last_index_new_depth = cint.last_depth_size = 0L; if (compile_index(&cint) == (UInt)FAILCODE) { Yap_ReleaseCMem(&cint); CleanCls(&cint); return FAILCODE; } #if DEBUG if (GLOBAL_Option['i' - 'a' + 1]) { Yap_ShowCode(&cint); } #endif /* globals for assembler */ LOCAL_IPredArity = ap->ArityOfPE; if (cint.CodeStart) { if ((indx_out = Yap_assemble(ASSEMBLING_INDEX, TermNil, ap, FALSE, &cint, cint.i_labelno+1)) == NULL) { if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) { Yap_ReleaseCMem(&cint); CleanCls(&cint); Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); return NULL; } goto restart_index; } } else { Yap_ReleaseCMem(&cint); CleanCls(&cint); return NULL; } Yap_ReleaseCMem(&cint); CleanCls(&cint); if (ap->PredFlags & LogUpdatePredFlag) { LogUpdIndex *cl = ClauseCodeToLogUpdIndex(indx_out); cl->ClFlags |= SwitchRootMask; } return(indx_out); } static istack_entry * push_stack(istack_entry *sp, Int arg, Term Tag, Term extra, struct intermediates *cint) { CACHE_REGS if (sp+1 > (istack_entry *)LOCAL_TrailTop) { save_machine_regs(); siglongjmp(cint->CompilerBotch,4); } sp->pos = arg; sp->val = Tag; sp->extra = extra; sp++; sp->pos = 0; return sp; } static istack_entry * install_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack) { istack_entry *sp = stack; while (sp->pos) { if ((Int)(sp->pos) > 0) { add_info(cls, sp->pos); } else if (sp->pos) { UInt argno = -sp->pos; add_arg_info(cls, ap, argno); } /* if we are not talking about a variable */ if (cls->Tag != sp->val) { if (sp->val == 0L) { sp++; } break; } else { if (IsApplTerm(cls->Tag)) { Functor f = (Functor)RepAppl(cls->Tag); if (IsExtensionFunctor(f)) { if (f == FunctorDBRef) { if (cls->ucd.t_ptr != sp->extra) break; } else if (f == FunctorDouble) { if (cls->ucd.t_ptr && Yap_Double_key(sp->extra) != Yap_Double_key(cls->ucd.t_ptr)) break; } else if (f == FunctorString) { if (cls->ucd.t_ptr && Yap_String_key(sp->extra) != Yap_String_key(cls->ucd.t_ptr)) break; } else { if (cls->ucd.t_ptr && Yap_Int_key(sp->extra) != Yap_Int_key(cls->ucd.t_ptr)) break; } } } if ((Int)(sp->pos) > 0) { move_next(cls, sp->pos); } else if (sp->pos) { UInt argno = -sp->pos; skip_to_arg(cls, ap, argno, FALSE); } } sp++; } return sp; } static ClauseDef * install_clauses(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop *beg, yamop *end) { istack_entry *sp = stack; if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(beg); UInt nclauses = mcl->ClPred->cs.p_code.NOfClauses; yamop *end = (yamop *)((char *)mcl->ClCode+nclauses*mcl->ClItemSize); yamop *cd = mcl->ClCode; if (stack[0].pos == 0) { while (TRUE) { cls->Code = cls->CurrentCode = cd; cls->Tag = 0; cls++; cd = (yamop *)((char *)cd+mcl->ClItemSize); if (cd == end) { return cls-1; } } } while (TRUE) { cls->Code = cls->CurrentCode = cd; sp = install_clause(cls, ap, stack); /* we reached a matching clause */ if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) { cls++; } cd = (yamop *)((char *)cd+mcl->ClItemSize); if (cd == end) { return cls-1; } } } else { StaticClause *cl = ClauseCodeToStaticClause(beg); if (stack[0].pos == 0) { while (TRUE) { cls->Code = cls->CurrentCode = cl->ClCode; cls->Tag = 0; cls++; if (cl->ClCode == end) { return cls-1; } cl = cl->ClNext; } } while (TRUE) { cls->Code = cls->CurrentCode = cl->ClCode; sp = install_clause(cls, ap, stack); /* we reached a matching clause */ if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) { cls++; } if (cl->ClCode == end || cl->ClCode == NULL) { return cls-1; } cl = cl->ClNext; } } } static ClauseDef * install_clauseseq(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop **beg, yamop **end) { istack_entry *sp = stack; if (stack[0].pos == 0) { while (TRUE) { if (*beg) { cls->Code = cls->CurrentCode = *beg; cls->Tag = 0; cls++; } beg++; if (beg == end) { return cls-1; } } } while (TRUE) { if (*beg) { cls->Code = cls->CurrentCode = *beg; sp = install_clause(cls, ap, stack); /* we reached a matching clause */ if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) { cls++; } } beg++; if (beg == end) { return cls-1; } } } static void reinstall_clauses(ClauseDef *cls, ClauseDef *end, PredEntry *ap, istack_entry *stack) { do { cls->CurrentCode = cls->Code; install_clause(cls, ap, stack); } while (cls++ != end); } static istack_entry * install_log_upd_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack) { istack_entry *sp = stack; while (sp->pos) { if ((Int)(sp->pos) > 0) { add_head_info(cls, sp->pos); } else if (sp->pos) { UInt argno = -sp->pos; add_arg_info(cls, ap, argno); } /* if we are not talking about a variable */ if (cls->Tag != sp->val) { if (sp->val == 0L) { sp++; } break; } else { if (IsApplTerm(cls->Tag)) { Functor f = (Functor)RepAppl(cls->Tag); if (IsExtensionFunctor(f)) { if (f == FunctorDBRef) { if (cls->ucd.t_ptr != sp->extra) break; } else if (f == FunctorDouble) { if (cls->ucd.t_ptr && Yap_Double_key(sp->extra) != Yap_Double_key(cls->ucd.t_ptr)) break; } else { if (cls->ucd.t_ptr && Yap_Int_key(sp->extra) != Yap_Int_key(cls->ucd.t_ptr)) break; } } } if ((Int)(sp->pos) > 0) { move_next(cls, sp->pos); } else if (sp->pos) { UInt argno = -sp->pos; skip_to_arg(cls, ap, argno, FALSE); } } sp++; } return sp; } static ClauseDef * install_log_upd_clauses(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop *beg, yamop *end) { istack_entry *sp = stack; if (stack[0].pos == 0) { while (TRUE) { cls->Code = cls->CurrentCode = beg; cls->Tag = 0; cls++; if (beg == end || beg == NULL) { return cls-1; } beg = ClauseCodeToLogUpdClause(beg)->ClNext->ClCode; } } while (TRUE) { cls->Code = cls->CurrentCode = beg; sp = install_log_upd_clause(cls, ap, stack); /* we reached a matching clause */ if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) { cls++; } if (beg == end || beg == NULL) { return cls-1; } beg = ClauseCodeToLogUpdClause(beg)->ClNext->ClCode; } } static ClauseDef * install_log_upd_clauseseq(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop **beg, yamop **end) { istack_entry *sp = stack; if (stack[0].pos == 0) { while (TRUE) { if (beg) { cls->Code = cls->CurrentCode = *beg; cls->Tag = 0; cls++; } beg++; if (beg == end) { return cls-1; } } } while (TRUE) { if (*beg) { cls->Code = cls->CurrentCode = *beg; sp = install_log_upd_clause(cls, ap, stack); /* we reached a matching clause */ if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) { cls++; } } beg++; if (beg == end) { return cls-1; } } } static void reinstall_log_upd_clauses(ClauseDef *cls, ClauseDef *end, PredEntry *ap, istack_entry *stack) { do { cls->CurrentCode = cls->Code; install_log_upd_clause(cls, ap, stack); } while (cls++ != end); } #if PRECOMPUTE_REGADDRESS #define arg_from_x(I) (((CELL *)(I))-XREGS) #else #define arg_from_x(I) (I) #endif /* ALIGN_LONGS */ static AtomSwiEntry * lookup_c(Term t, yamop *tab, COUNT entries) { AtomSwiEntry *cebase = (AtomSwiEntry *)tab; while (cebase->Tag != t) { entries--; cebase++; if (entries == 0) return cebase; } return cebase; } static FuncSwiEntry * lookup_f(Functor f, yamop *tab, COUNT entries) { FuncSwiEntry *febase = (FuncSwiEntry *)tab; while (febase->Tag != f) { entries--; febase++; if (entries == 0) return febase; } return febase; } static COUNT count_clauses_left(yamop *cl, PredEntry *ap) { if (ap->PredFlags & LogUpdatePredFlag) { LogUpdClause *c = ClauseCodeToLogUpdClause(cl); COUNT i = 0; while (c != NULL) { i++; c = c->ClNext; } return i; } else if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause); UInt ncls = mcl->ClPred->cs.p_code.NOfClauses; return (ncls-1)-((char *)cl-(char *)mcl->ClCode)/mcl->ClItemSize; } else { yamop *last = ap->cs.p_code.LastClause; StaticClause *c; COUNT i = 1; c = ClauseCodeToStaticClause(cl); while (c->ClCode != last) { i++; c = c->ClNext; } return i; } } /* We have jumped across indexing code. Check if we jumped within the current indexing block, if we moved back to a parent, or if we jumped to a child. */ static ClausePointer index_jmp(ClausePointer cur, ClausePointer parent, yamop *ipc, int is_lu, yamop *e_code) { if (cur.lui == NULL || ipc == FAILCODE || ipc == e_code || ipc->opc == Yap_opcode(_expand_clauses) ) return cur; if (is_lu) { LogUpdIndex *lcur = cur.lui, *ncur; /* check myself */ if (ipc >= lcur->ClCode && ipc < (yamop *)((CODEADDR)lcur+lcur->ClSize)) return cur; /* check if I am returning back to a parent, eg switch with intermediate node */ if (lcur->ParentIndex) { LogUpdIndex *pcur = lcur->ParentIndex; if (ipc >= pcur->ClCode && ipc < (yamop *)((CODEADDR)pcur+pcur->ClSize)) { cur.lui = pcur; return cur; } } /* maybe I am a new group */ ncur = ClauseCodeToLogUpdIndex(ipc); if (ncur->ParentIndex != lcur) { #if DEBUG fprintf(stderr,"OOPS, bad parent in lu index\n"); #endif cur.lui = NULL; return cur; } cur.lui = ncur; return cur; } else { StaticIndex *scur = parent.si, *ncur; /* check myself */ if (!scur) return cur; if (ipc >= scur->ClCode && ipc < (yamop *)((CODEADDR)scur+scur->ClSize)) return cur; ncur = ClauseCodeToStaticIndex(ipc); if (ncur->ClPred == scur->ClPred) { cur.si = ncur; return cur; } /* if (parent.si != cur.si) { if (parent.si) { StaticIndex *pcur = parent.si; if (ipc >= pcur->ClCode && ipc < (yamop *)((CODEADDR)pcur+pcur->ClSize)) return parent; } } cur.si = ncur; return cur; */ cur.si = NULL; return cur; } } static ClausePointer code_to_indexcl(yamop *ipc, int is_lu) { ClausePointer ret; if (is_lu) ret.lui = ClauseCodeToLogUpdIndex(ipc); else ret.si = ClauseCodeToStaticIndex(ipc); return ret; } /* CALLED by expand when entering sub_arg */ static void increase_expand_depth(yamop *ipc, struct intermediates *cint) { yamop *ncode; cint->term_depth++; if (ipc->opc == Yap_opcode(_switch_on_sub_arg_type) && (ncode = ipc->u.sllll.l4)->opc == Yap_opcode(_expand_clauses)) { if (ncode->u.sssllp.s2 != cint->last_depth_size) { cint->last_index_new_depth = cint->term_depth; cint->last_depth_size = ncode->u.sssllp.s2; } } } static void zero_expand_depth(PredEntry *ap, struct intermediates *cint) { cint->term_depth = cint->last_index_new_depth; cint->last_depth_size = ap->cs.p_code.NOfClauses; } static yamop ** expand_index(struct intermediates *cint) { CACHE_REGS /* first clause */ PredEntry *ap = cint->CurrentPred; yamop *first, *last = NULL, *alt = NULL; istack_entry *stack, *sp; ClauseDef *max; int NClauses; /* last clause to experiment with */ yamop *ipc; /* labp should point at the beginning of the sequence */ yamop **labp = NULL; ClausePointer parentcl; Term t = TermNil, *s_reg = NULL; int is_last_arg = TRUE; int argno = 1; int isfirstcl = TRUE; /* this is will be used as a new PC */ CELL *top = (CELL *) TR; UInt arity = 0; UInt lab, fail_l, clleft, i = 0; int is_lu = ap->PredFlags & LogUpdatePredFlag; yamop *e_code = (yamop *)&(ap->cs.p_code.ExpandCode); ipc = ap->cs.p_code.TrueCodeOfPred; first = ap->cs.p_code.FirstClause; NClauses = ap->cs.p_code.NOfClauses; sp = stack = (istack_entry *)top; cint->i_labelno = 1; stack[0].pos = 0; /* try to refine the interval using the indexing code */ cint->term_depth = cint->last_index_new_depth = cint->last_depth_size = 0L; parentcl = code_to_indexcl(ipc,is_lu); while (ipc != NULL) { op_numbers op; op = Yap_op_from_opcode(ipc->opc); switch(op) { case _try_clause: case _retry: /* this clause had no indexing */ if (ap->PredFlags & LogUpdatePredFlag) { first = ClauseCodeToLogUpdClause(ipc->u.Otapl.d)->ClNext->ClCode; } else if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause); first = (yamop *)((char *)ipc->u.Otapl.d)+mcl->ClItemSize; } else { first = ClauseCodeToStaticClause(ipc->u.Otapl.d)->ClNext->ClCode; } isfirstcl = FALSE; ipc = NEXTOP(ipc,Otapl); break; #if TABLING case _table_try: case _table_retry: /* this clause had no indexing */ first = ClauseCodeToStaticClause(PREVOP(ipc->u.Otapl.d,Otapl))->ClNext->ClCode; isfirstcl = FALSE; ipc = NEXTOP(ipc,Otapl); break; #endif /* TABLING */ case _try_clause2: case _try_clause3: case _try_clause4: case _retry2: case _retry3: case _retry4: case _try_in: if (ap->PredFlags & LogUpdatePredFlag) { first = ClauseCodeToLogUpdClause(ipc->u.l.l)->ClNext->ClCode; } else if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause); first = (yamop *)((char *)ipc->u.Otapl.d)+mcl->ClItemSize; } else { first = ClauseCodeToStaticClause(ipc->u.l.l)->ClNext->ClCode; } isfirstcl = FALSE; ipc = NEXTOP(ipc,l); break; case _retry_me: #ifdef TABLING case _table_retry_me: #endif isfirstcl = FALSE; case _try_me: #ifdef TABLING case _table_try_me: #endif /* ok, we found the start for an indexing block, but we don't if we are going to operate here or not */ /* if we are to commit here, alt will tell us where */ alt = ipc->u.Otapl.d; ipc = NEXTOP(ipc,Otapl); /* start of a group, reset stack */ sp = stack; stack[0].pos = 0; break; case _profiled_trust_me: case _trust_me: case _count_trust_me: #ifdef TABLING case _table_trust_me: #endif /* TABLING */ /* we will commit to this group for sure */ ipc = NEXTOP(ipc,Otapl); alt = NULL; /* start of a group, reset stack */ sp = stack; stack[0].pos = 0; break; case _trust: /* we should never be here */ Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "found trust in expand_index"); labp = NULL; ipc = NULL; break; /* should we ever be here ? I think not */ case _try_logical: case _retry_logical: case _count_retry_logical: case _profiled_retry_logical: ipc = ipc->u.OtaLl.n; break; case _trust_logical: case _count_trust_logical: case _profiled_trust_logical: ipc = ipc->u.OtILl.n; break; case _enter_lu_pred: /* no useful info */ ipc = ipc->u.Illss.l1; break; case _retry_profiled: case _count_retry: /* no useful info */ ipc = NEXTOP(ipc,l); break; case _jump: /* just skip for now, but should worry about memory management */ ipc = ipc->u.l.l; /* I don't know how up I will go */ parentcl.si = NULL; break; case _lock_lu: case _procceed: ipc = NEXTOP(ipc,p); break; case _unlock_lu: ipc = NEXTOP(ipc,e); break; case _jump_if_var: if (IsVarTerm(Deref(ARG1))) { labp = &(ipc->u.l.l); ipc = ipc->u.l.l; parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); } else { ipc = NEXTOP(ipc,l); } break; case _jump_if_nonvar: argno = arg_from_x(ipc->u.xll.x); t = Deref(XREGS[argno]); i = 0; /* expand_index expects to find the new argument */ if (!IsVarTerm(t)) { argno--; labp = &(ipc->u.xll.l1); ipc = ipc->u.xll.l1; parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); } else { ipc = NEXTOP(ipc,xll); } break; /* instructions type EC */ /* instructions type e */ case _index_dbref: t = AbsAppl(s_reg-1); sp[-1].extra = t; s_reg = NULL; ipc = NEXTOP(ipc,e); break; case _index_blob: t = Yap_DoubleP_key(s_reg); sp[-1].extra = AbsAppl(s_reg-1); s_reg = NULL; ipc = NEXTOP(ipc,e); break; case _index_long: t = Yap_IntP_key(s_reg); sp[-1].extra = AbsAppl(s_reg-1); s_reg = NULL; ipc = NEXTOP(ipc,e); break; case _user_switch: labp = &(ipc->u.lp.l); ipc = ipc->u.lp.l; break; /* instructions type e */ case _switch_on_type: zero_expand_depth(ap, cint); t = Deref(ARG1); argno = 1; i = 0; if (IsVarTerm(t)) { labp = &(ipc->u.llll.l4); ipc = ipc->u.llll.l4; } else if (IsPairTerm(t)) { sp = push_stack(sp, 1, AbsPair(NULL), TermNil, cint); s_reg = RepPair(t); labp = &(ipc->u.llll.l1); ipc = ipc->u.llll.l1; increase_expand_depth(ipc, cint); } else if (IsApplTerm(t)) { sp = push_stack(sp, 1, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint); ipc = ipc->u.llll.l3; increase_expand_depth(ipc, cint); } else { sp = push_stack(sp, argno, t, TermNil, cint); ipc = ipc->u.llll.l2; } parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); break; case _switch_list_nl: zero_expand_depth(ap, cint); t = Deref(ARG1); argno = 1; i = 0; if (IsVarTerm(t)) { labp = &(ipc->u.ollll.l4); ipc = ipc->u.ollll.l4; } else if (IsPairTerm(t)) { s_reg = RepPair(t); labp = &(ipc->u.ollll.l1); sp = push_stack(sp, 1, AbsPair(NULL), TermNil, cint); ipc = ipc->u.ollll.l1; increase_expand_depth(ipc, cint); } else if (t == TermNil) { sp = push_stack(sp, 1, t, TermNil, cint); ipc = ipc->u.ollll.l2; increase_expand_depth(ipc, cint); } else { Term tn; if (IsApplTerm(t)) { tn = AbsAppl((CELL *)FunctorOfTerm(t)); } else { tn = t; } sp = push_stack(sp, argno, tn, TermNil, cint); ipc = ipc->u.ollll.l3; } parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); break; case _switch_on_arg_type: zero_expand_depth(ap, cint); argno = arg_from_x(ipc->u.xllll.x); i = 0; t = Deref(XREGS[argno]); if (IsVarTerm(t)) { labp = &(ipc->u.xllll.l4); ipc = ipc->u.xllll.l4; } else if (IsPairTerm(t)) { s_reg = RepPair(t); sp = push_stack(sp, argno, AbsPair(NULL), TermNil, cint); labp = &(ipc->u.xllll.l1); ipc = ipc->u.xllll.l1; increase_expand_depth(ipc, cint); } else if (IsApplTerm(t)) { sp = push_stack(sp, argno, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint); ipc = ipc->u.xllll.l3; increase_expand_depth(ipc, cint); } else { sp = push_stack(sp, argno, t, TermNil, cint); ipc = ipc->u.xllll.l2; } parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); break; case _switch_on_sub_arg_type: i = ipc->u.sllll.s; t = Deref(s_reg[i]); if (i != arity-1) is_last_arg = FALSE; t = Deref(s_reg[i]); if (IsVarTerm(t)) { labp = &(ipc->u.sllll.l4); ipc = ipc->u.sllll.l4; i++; } else if (IsPairTerm(t)) { s_reg = RepPair(t); sp = push_stack(sp, -i-1, AbsPair(NULL), TermNil, cint); labp = &(ipc->u.sllll.l1); ipc = ipc->u.sllll.l1; i = 0; increase_expand_depth(ipc, cint); } else if (IsApplTerm(t)) { sp = push_stack(sp, -i-1, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint); ipc = ipc->u.sllll.l3; i = 0; increase_expand_depth(ipc, cint); } else { /* We don't push stack here, instead we go over to next argument sp = push_stack(sp, -i-1, t, cint); */ sp = push_stack(sp, -i-1, t, TermNil, cint); ipc = ipc->u.sllll.l2; i++; } parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code); break; case _if_not_then: labp = NULL; ipc = NULL; break; /* instructions type ollll */ case _switch_on_func: case _if_func: case _go_on_func: { FuncSwiEntry *fe; yamop *newpc; Functor f; s_reg = RepAppl(t); f = (Functor)(*s_reg++); if (op == _switch_on_func) { fe = lookup_f_hash(f,ipc->u.sssl.l,ipc->u.sssl.s); } else { fe = lookup_f(f,ipc->u.sssl.l,ipc->u.sssl.s); } newpc = fe->u_f.labp; labp = &(fe->u_f.labp); if (newpc == e_code) { /* we found it */ parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu); ipc = NULL; } else { ClausePointer npar = code_to_indexcl(ipc->u.sssl.l,is_lu); ipc = newpc; parentcl = index_jmp(npar, parentcl, ipc, is_lu, e_code); } } break; case _switch_on_cons: case _if_cons: case _go_on_cons: { AtomSwiEntry *ae; if (op == _switch_on_cons) { ae = lookup_c_hash(t,ipc->u.sssl.l,ipc->u.sssl.s); } else { ae = lookup_c(t,ipc->u.sssl.l,ipc->u.sssl.s); } labp = &(ae->u_a.labp); if (ae->u_a.labp == e_code) { /* we found it */ parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu); ipc = NULL; } else { ClausePointer npar = code_to_indexcl(ipc->u.sssl.l,is_lu); ipc = ae->u_a.labp; parentcl = index_jmp(npar, parentcl, ipc, is_lu, e_code); } } break; case _expand_index: case _expand_clauses: if (alt != NULL && ap->PredFlags & LogUpdatePredFlag) { op_numbers fop = Yap_op_from_opcode(alt->opc); if (fop == _enter_lu_pred) alt = alt->u.Illss.l1; } ipc = NULL; break; case _op_fail: ipc = alt; alt = NULL; break; default: if (alt == NULL) { Yap_Error(INTERNAL_COMPILER_ERROR,t,"unexpected instruction %d at expand_index ", op); labp = NULL; ipc = NULL; } else { /* backtrack */ first = alt->u.Otapl.d; ipc = alt; alt = NULL; } } } /* if there was an overflow while generating the code, make sure S is still correct */ if (is_lu) { cint->current_cl.lui = parentcl.lui; } else { cint->current_cl.si = parentcl.si; } if (s_reg != NULL) S = s_reg; #ifdef TABLING /* handle tabling hack that insertes a failcode, this really corresponds to not having any more clauses */ if (alt == TRUSTFAILCODE) alt = NULL; #endif if (alt == NULL) { /* oops, we are at last clause */ fail_l = (UInt)FAILCODE; clleft = 0; last = ap->cs.p_code.LastClause; } else { if (ap->PredFlags & LogUpdatePredFlag) { op_numbers op = Yap_op_from_opcode(alt->opc); /* can we be here */ if (op >= _retry2 && op <= _retry4) { last = alt->u.l.l; } else { last = alt->u.Otapl.d; } } else { op_numbers op = Yap_op_from_opcode(alt->opc); if (op == _retry || op == _trust) { last = alt->u.Otapl.d; #ifdef TABLING } else if (op == _table_retry || op == _table_trust) { last = PREVOP(alt->u.Otapl.d,Otapl); #endif /* TABLING */ } else if (op >= _retry2 && op <= _retry4) { last = alt->u.l.l; } } fail_l = (UInt)alt; clleft = count_clauses_left(last,ap); } if (Yap_op_from_opcode((*labp)->opc) == _expand_clauses) { /* ok, we know how many clauses */ yamop *ipc = *labp; /* check all slots, not just the ones with values */ COUNT nclauses = ipc->u.sssllp.s1; yamop **clp = (yamop **)NEXTOP(ipc,sssllp); cint->expand_block = ipc; #if USE_SYSTEM_MALLOC if (!cint->cls) { cint->cls = (ClauseDef *)Yap_AllocCodeSpace(nclauses*sizeof(ClauseDef)); if (!cint->cls) { /* tell how much space we need */ LOCAL_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } } #else cint->cls = (ClauseDef *)HR; if (cint->cls+2*nclauses > (ClauseDef *)(ASP-4096)) { /* tell how much space we need (worst case) */ LOCAL_Error_Size += 2*NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,3); } #endif if (ap->PredFlags & LogUpdatePredFlag) { max = install_log_upd_clauseseq(cint->cls, ap, stack, clp, clp+nclauses); } else { max = install_clauseseq(cint->cls, ap, stack, clp, clp+nclauses); } } else { cint->expand_block = NULL; #if USE_SYSTEM_MALLOC if (!cint->cls) { cint->cls = (ClauseDef *)Yap_AllocCodeSpace(NClauses*sizeof(ClauseDef)); if (!cint->cls) { /* tell how much space we need */ LOCAL_Error_Size += NClauses*sizeof(ClauseDef); /* grow stack */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } } #else cint->cls = (ClauseDef *)HR; if (cint->cls+2*NClauses > (ClauseDef *)(ASP-4096)) { /* tell how much space we need (worst case) */ LOCAL_Error_Size += 2*NClauses*sizeof(ClauseDef); save_machine_regs(); siglongjmp(cint->CompilerBotch,3); } #endif if (ap->PredFlags & LogUpdatePredFlag) { max = install_log_upd_clauses(cint->cls, ap, stack, first, last); } else { max = install_clauses(cint->cls, ap, stack, first, last); } #if DEBUG_EXPAND if (ap->PredFlags & LogUpdatePredFlag) { fprintf(stderr,"vsc +"); } else { fprintf(stderr,"vsc "); } fprintf(stderr," : expanding %d out of %d\n", (max-cls)+1,NClauses); #endif } /* don't count last clause if you don't have to */ if (alt && max->Code == last) max--; if (max < cint->cls && labp != NULL) { *labp = FAILCODE; return labp; } #if USE_SYSTEM_MALLOC cint->freep = (char *)HR; #else cint->freep = (char *)(max+1); #endif cint->CodeStart = cint->BlobsStart = cint->cpc = cint->icpc = NULL; if (!IsVarTerm(sp[-1].val) && sp > stack) { if (IsAtomOrIntTerm(sp[-1].val)) { if (s_reg == NULL) { /* we have not yet looked into terms */ lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top); } else { UInt arity = 0; if (ap->PredFlags & LogUpdatePredFlag) { reinstall_log_upd_clauses(cint->cls, max, ap, stack); } else { reinstall_clauses(cint->cls, max, ap, stack); } sp--; while (sp > stack) { Term t = sp[-1].val; if (IsApplTerm(t)) { Functor f = (Functor)RepAppl(t); if (!IsExtensionFunctor(f)) { arity = ArityOfFunctor(f); break; } else { sp--; } } else if (IsPairTerm(t)) { arity = 2; break; } else { sp--; } } lab = do_compound_index(cint->cls, max, s_reg, cint, i, arity, argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE); } } else if (IsPairTerm(sp[-1].val) && sp > stack) { lab = do_compound_index(cint->cls, max, s_reg, cint, i, 2, argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE); } else { Functor f = (Functor)RepAppl(sp[-1].val); /* we are continuing within a compound term */ if (IsExtensionFunctor(f)) { lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top); } else { lab = do_compound_index(cint->cls, max, s_reg, cint, i, ArityOfFunctor(f), argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE); } } } else { if (argno == ap->ArityOfPE) { lab = do_var_clauses(cint->cls, max, FALSE, cint, isfirstcl, clleft, fail_l, ap->ArityOfPE+1); } else { lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top); } } if (labp && !(lab & 1)) { *labp = (yamop *)lab; /* in case we have a single clause */ } return labp; } static yamop * ExpandIndex(PredEntry *ap, int ExtraArgs, yamop *nextop USES_REGS) { yamop *indx_out, *expand_clauses; yamop **labp; int cb; struct intermediates cint; cint.blks = NULL; cint.cls = NULL; cint.code_addr = NULL; cint.label_offset = NULL; if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) { CACHE_REGS restore_machine_regs(); /* grow stack */ recover_from_failed_susp_on_cls(&cint, 0); Yap_gcl(LOCAL_Error_Size, ap->ArityOfPE+ExtraArgs, ENV, nextop); } else if (cb == 2) { restore_machine_regs(); LOCAL_Error_Size = recover_from_failed_susp_on_cls(&cint, LOCAL_Error_Size); if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) { save_machine_regs(); if (ap->PredFlags & LogUpdatePredFlag) { Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap); } else { StaticIndex *cl; cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred); Yap_kill_iblock((ClauseUnion *)cl,NULL, ap); } #if defined(YAPOR) || defined(THREADS) if (ap->PredFlags & LogUpdatePredFlag && !(ap->PredFlags & ThreadLocalPredFlag) && ap->ModuleOfPred != IDB_MODULE) { ap->OpcodeOfPred = LOCKPRED_OPCODE; ap->cs.p_code.TrueCodeOfPred = ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); } else { #endif ap->OpcodeOfPred = INDEX_OPCODE; ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); #if defined(YAPOR) || defined(THREADS) } #endif Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); CleanCls(&cint); return FAILCODE; } } else if (cb == 4) { restore_machine_regs(); Yap_ReleaseCMem(&cint); if (!Yap_growtrail(LOCAL_Error_Size, FALSE)) { save_machine_regs(); if (ap->PredFlags & LogUpdatePredFlag) { Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap); } else { StaticIndex *cl; cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred); Yap_kill_iblock((ClauseUnion *)cl, NULL, ap); } CleanCls(&cint); return FAILCODE; } } restart_index: cint.CodeStart = cint.cpc = cint.BlobsStart = cint.icpc = NIL; cint.CurrentPred = ap; LOCAL_ErrorMessage = NULL; LOCAL_Error_Size = 0; if (P->opc == Yap_opcode(_expand_clauses)) { expand_clauses = P; } else { expand_clauses = NULL; } #if DEBUG if (GLOBAL_Option['i' - 'a' + 1]) { Term tmod = ap->ModuleOfPred; if (!tmod) tmod = TermProlog; #if THREADS Yap_DebugPlWrite(MkIntegerTerm(worker_id)); Yap_DebugPutc(LOCAL_c_error_stream,' '); #endif Yap_DebugPutc(LOCAL_c_error_stream,'>'); Yap_DebugPutc(LOCAL_c_error_stream,'\t'); Yap_DebugPlWrite(tmod); Yap_DebugPutc(LOCAL_c_error_stream,':'); if (ap->ModuleOfPred == IDB_MODULE) { Term t = Deref(ARG1); if (IsAtomTerm(t)) { Yap_DebugPlWrite(t); } else if (IsIntegerTerm(t)) { Yap_DebugPlWrite(t); } else { Functor f = FunctorOfTerm(t); Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } else { if (ap->ArityOfPE == 0) { Atom At = (Atom)ap->FunctorOfPred; Yap_DebugPlWrite(MkAtomTerm(At)); } else { Functor f = ap->FunctorOfPred; Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } Yap_DebugPutc(LOCAL_c_error_stream,'\n'); #if THREADS Yap_DebugPlWrite(MkIntegerTerm(worker_id)); Yap_DebugPutc(LOCAL_c_error_stream,' '); #endif } #endif if ((labp = expand_index(&cint)) == NULL) { if (expand_clauses) { P = FAILCODE; recover_ecls_block(expand_clauses); } Yap_ReleaseCMem(&cint); CleanCls(&cint); return FAILCODE; } if (*labp == FAILCODE) { if (expand_clauses) { P = FAILCODE; recover_ecls_block(expand_clauses); } Yap_ReleaseCMem(&cint); CleanCls(&cint); return FAILCODE; } #if DEBUG if (GLOBAL_Option['i' - 'a' + 1]) { Yap_ShowCode(&cint); } #endif /* globals for assembler */ LOCAL_IPredArity = ap->ArityOfPE; if (cint.CodeStart) { if ((indx_out = Yap_assemble(ASSEMBLING_EINDEX, TermNil, ap, FALSE, &cint, cint.i_labelno+1)) == NULL) { if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); Yap_ReleaseCMem(&cint); CleanCls(&cint); return FAILCODE; } goto restart_index; } } else { /* single case */ if (expand_clauses) { P = *labp; recover_ecls_block(expand_clauses); } Yap_ReleaseCMem(&cint); CleanCls(&cint); return *labp; } if (indx_out == NULL) { if (expand_clauses) { P = FAILCODE; recover_ecls_block(expand_clauses); } Yap_ReleaseCMem(&cint); CleanCls(&cint); return FAILCODE; } Yap_ReleaseCMem(&cint); CleanCls(&cint); *labp = indx_out; if (ap->PredFlags & LogUpdatePredFlag) { /* add to head of current code children */ LogUpdIndex *ic = cint.current_cl.lui, *nic = ClauseCodeToLogUpdIndex(indx_out); if (ic == NULL) ic = (LogUpdIndex *)Yap_find_owner_index((yamop *)labp, ap); /* insert myself in the indexing code chain */ nic->SiblingIndex = ic->ChildIndex; nic->PrevSiblingIndex = NULL; if (ic->ChildIndex) { ic->ChildIndex->PrevSiblingIndex = nic; } nic->ParentIndex = ic; nic->ClFlags &= ~SwitchRootMask; ic->ChildIndex = nic; ic->ClRefCount++; } else { /* add to head of current code children */ StaticIndex *ic = cint.current_cl.si, *nic = ClauseCodeToStaticIndex(indx_out); if (ic == NULL) ic = (StaticIndex *)Yap_find_owner_index((yamop *)labp, ap); /* insert myself in the indexing code chain */ nic->SiblingIndex = ic->ChildIndex; ic->ChildIndex = nic; } if (expand_clauses) { P = indx_out; recover_ecls_block(expand_clauses); } return indx_out; } yamop * Yap_ExpandIndex(PredEntry *ap, UInt nargs) { CACHE_REGS return ExpandIndex(ap, nargs, CP PASS_REGS); } static path_stack_entry * push_path(path_stack_entry *sp, yamop **pipc, ClauseDef *clp, struct intermediates *cint) { CACHE_REGS if (sp+1 > (path_stack_entry *)LOCAL_TrailTop) { save_machine_regs(); siglongjmp(cint->CompilerBotch,4); } sp->flag = pc_entry; sp->uip.pce.pi_pc = pipc; sp->uip.pce.code = clp->Code; sp->uip.pce.current_code = clp->CurrentCode; sp->uip.pce.work_pc = clp->ucd.WorkPC; sp->uip.pce.tag = clp->Tag; return sp+1; } static path_stack_entry * fetch_new_block(path_stack_entry *sp, yamop **pipc, PredEntry *ap, struct intermediates *cint) { CACHE_REGS if (sp+1 > (path_stack_entry *)LOCAL_TrailTop) { save_machine_regs(); siglongjmp(cint->CompilerBotch,4); } /* add current position */ sp->flag = block_entry; sp->uip.cle.entry_code = pipc; if (ap->PredFlags & LogUpdatePredFlag) { sp->uip.cle.block = (ClauseUnion *)ClauseCodeToLogUpdIndex(*pipc); } else { sp->uip.cle.block = (ClauseUnion *)ClauseCodeToStaticIndex(*pipc); } return sp+1; } static path_stack_entry * init_block_stack(path_stack_entry *sp, yamop *ipc, PredEntry *ap) { /* add current position */ sp->flag = block_entry; sp->uip.cle.entry_code = NULL; if (ap->PredFlags & LogUpdatePredFlag) { sp->uip.cle.block = (ClauseUnion *)ClauseCodeToLogUpdIndex(ipc); } else { sp->uip.cle.block = (ClauseUnion *)ClauseCodeToStaticIndex(ipc); } return sp+1; } static path_stack_entry * cross_block(path_stack_entry *sp, yamop **pipc, PredEntry *ap, struct intermediates *cint) { yamop *ipc = *pipc; path_stack_entry *tsp = sp; ClauseUnion *block; do { UInt bsize; while ((--tsp)->flag != block_entry); block = tsp->uip.cle.block; if (block->lui.ClFlags & LogUpdMask) bsize = block->lui.ClSize; else bsize = block->si.ClSize; if (ipc > (yamop *)block && ipc < (yamop *)((CODEADDR)block + bsize)) { path_stack_entry *nsp = tsp+1; for (;tspflag == pc_entry) { if (nsp != tsp) { nsp->flag = pc_entry; nsp->uip.pce.pi_pc = tsp->uip.pce.pi_pc; nsp->uip.pce.code = tsp->uip.pce.code; nsp->uip.pce.current_code = tsp->uip.pce.current_code; nsp->uip.pce.work_pc = tsp->uip.pce.work_pc; nsp->uip.pce.tag = tsp->uip.pce.tag; } nsp++; } } return nsp; } } while (tsp->uip.cle.entry_code != NULL); /* moved to a new block */ return fetch_new_block(sp, pipc, ap, cint); } static yamop * pop_path(path_stack_entry **spp, ClauseDef *clp, PredEntry *ap, struct intermediates *cint) { path_stack_entry *sp = *spp; yamop *nipc; while ((--sp)->flag != pc_entry); *spp = sp; clp->Code = sp->uip.pce.code; clp->CurrentCode = sp->uip.pce.current_code; clp->ucd.WorkPC = sp->uip.pce.work_pc; clp->Tag = sp->uip.pce.tag; if (sp->uip.pce.pi_pc == NULL) { *spp = sp; return NULL; } nipc = *(sp->uip.pce.pi_pc); *spp = cross_block(sp, sp->uip.pce.pi_pc, ap, cint); return nipc; } static int table_fe_overflow(yamop *pc, Functor f) { if (pc->u.sssl.s <= MIN_HASH_ENTRIES) { /* we cannot expand otherwise */ COUNT i; FuncSwiEntry *csw = (FuncSwiEntry *)pc->u.sssl.l; for (i=0; i < pc->u.sssl.s; i++,csw++) { if (csw->Tag == f) return FALSE; } return TRUE; } else { COUNT free = pc->u.sssl.s-pc->u.sssl.e; return (!free || pc->u.sssl.s/free > 4); } } static int table_ae_overflow(yamop *pc, Term at) { if (pc->u.sssl.s <= MIN_HASH_ENTRIES) { /* check if we are already there */ COUNT i; AtomSwiEntry *csw = (AtomSwiEntry *)pc->u.sssl.l; for (i=0; i < pc->u.sssl.s; i++,csw++) { if (csw->Tag == at) return FALSE; } return TRUE; } else { COUNT free = pc->u.sssl.s-pc->u.sssl.e; return (!free || pc->u.sssl.s/free > 4); } } static void replace_index_block(ClauseUnion *parent_block, yamop *cod, yamop *ncod, PredEntry *ap) { if (ap->PredFlags & LogUpdatePredFlag) { LogUpdIndex *cl = ClauseCodeToLogUpdIndex(cod), *ncl = ClauseCodeToLogUpdIndex(ncod), *c = parent_block->lui.ChildIndex; ncl->SiblingIndex = cl->SiblingIndex; ncl->PrevSiblingIndex = cl->PrevSiblingIndex; ncl->ClRefCount = cl->ClRefCount; ncl->ChildIndex = cl->ChildIndex; ncl->ParentIndex = cl->ParentIndex; ncl->ClPred = cl->ClPred; // INIT_LOCK(ncl->ClLock); if (c == cl) { parent_block->lui.ChildIndex = ncl; } else { if (cl->PrevSiblingIndex) cl->PrevSiblingIndex->SiblingIndex = ncl; } if (cl->SiblingIndex) { cl->SiblingIndex->PrevSiblingIndex = ncl; } c = cl->ChildIndex; while (c != NULL) { c->ParentIndex = ncl; c = c->SiblingIndex; } Yap_InformOfRemoval(cl); Yap_LUIndexSpace_SW -= cl->ClSize; Yap_FreeCodeSpace((char *)cl); } else { StaticIndex *cl = ClauseCodeToStaticIndex(cod), *ncl = ClauseCodeToStaticIndex(ncod), *c = parent_block->si.ChildIndex; ncl->SiblingIndex = cl->SiblingIndex; ncl->ClPred = cl->ClPred; if (c == cl) { parent_block->si.ChildIndex = ncl; } else { while (c->SiblingIndex != cl) { c = c->SiblingIndex; } c->SiblingIndex = ncl; } Yap_InformOfRemoval(cl); Yap_IndexSpace_SW -= cl->ClSize; Yap_FreeCodeSpace((char *)cl); } } static AtomSwiEntry * expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at) { PredEntry *ap = cint->CurrentPred; int n = pc->u.sssl.s, i, i0 = n; UInt fail_l = Zero; AtomSwiEntry *old_ae = (AtomSwiEntry *)(pc->u.sssl.l), *target; if (n > MIN_HASH_ENTRIES) { AtomSwiEntry *tmp = old_ae; int i; n = 1; for (i = 0; i < pc->u.sssl.s; i++,tmp++) { if (tmp->Tag != Zero) n++; else fail_l = tmp->u_a.Label; } } else { fail_l = old_ae[n].u_a.Label; n++; } if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, i, n0; n0 = n+1+n/4; while (cases < n0) cases *= 2; if (cases == pc->u.sssl.s) { return fetch_centry(old_ae, at, n-1, n); } /* initialise */ target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint, 0); pc->opc = Yap_opcode(_switch_on_cons); pc->u.sssl.s = cases; for (i=0; iopc = Yap_opcode(_if_cons); pc->u.sssl.s = n; target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0); target[n].Tag = Zero; target[n].u_a.Label = fail_l; } for (i = 0; i < i0; i++,old_ae++) { Term tag = old_ae->Tag; if (tag != Zero) { AtomSwiEntry *ics = fetch_centry(target, tag, i, n); ics->Tag = tag; ics->u_a.Label = old_ae->u_a.Label; } } /* support for threads */ if (blk) replace_index_block(blk, pc->u.sssl.l, (yamop *)target, ap); pc->u.sssl.l = (yamop *)target; return fetch_centry(target, at, n-1, n); } static FuncSwiEntry * expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f) { PredEntry *ap = cint->CurrentPred; int n = pc->u.sssl.s, i, i0 = n; UInt fail_l = Zero; FuncSwiEntry *old_fe = (FuncSwiEntry *)(pc->u.sssl.l), *target; if (n > MIN_HASH_ENTRIES) { FuncSwiEntry *tmp = old_fe; int i; n = 1; for (i = 0; i < pc->u.sssl.s; i++,tmp++) { if (tmp->Tag != Zero) n++; else fail_l = tmp->u_f.Label; } } else { fail_l = old_fe[n].u_f.Label; n++; } if (n > MIN_HASH_ENTRIES) { int cases = MIN_HASH_ENTRIES, i, n0; n0 = n+1+n/4; while (cases < n0) cases *= 2; if (cases == pc->u.sssl.s) { return fetch_fentry(old_fe, f, n-1, n); } pc->opc = Yap_opcode(_switch_on_func); pc->u.sssl.s = cases; pc->u.sssl.e = n; pc->u.sssl.w = 0; /* initialise */ target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint, FuncSwitchMask); for (i=0; iopc = Yap_opcode(_if_func); pc->u.sssl.s = n; pc->u.sssl.e = n; pc->u.sssl.w = 0; target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask); target[n].Tag = Zero; target[n].u_f.Label = fail_l; } for (i = 0; i < i0; i++,old_fe++) { Functor f = old_fe->Tag; if (f != NULL) { FuncSwiEntry *ifs = fetch_fentry(target, f, i, n); ifs->Tag = old_fe->Tag; ifs->u_f.Label = old_fe->u_f.Label; } } replace_index_block(blk, pc->u.sssl.l, (yamop *)target, ap); pc->u.sssl.l = (yamop *)target; return fetch_fentry(target, f, n-1, n); } static void clean_ref_to_clause(LogUpdClause *tgl) { tgl->ClRefCount--; if ((tgl->ClFlags & ErasedMask) && !(tgl->ClRefCount) && !(tgl->ClFlags & InUseMask)) { /* last ref to the clause */ Yap_ErLogUpdCl(tgl); } } static ClauseUnion * current_block(path_stack_entry *sp) { while ((--sp)->flag != block_entry); return sp->uip.cle.block; } static path_stack_entry * kill_block(path_stack_entry *sp, PredEntry *ap) { while ((--sp)->flag != block_entry); if (sp->uip.cle.entry_code == NULL) { Yap_kill_iblock(sp->uip.cle.block, NULL, ap); } else { path_stack_entry *nsp = sp; while ((--nsp)->flag != block_entry); Yap_kill_iblock(sp->uip.cle.block, nsp->uip.cle.block, ap); *sp->uip.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode); } return sp; } static LogUpdClause * find_last_clause(yamop *start) { while (start->u.OtaLl.d->ClFlags & ErasedMask) start = start->u.OtaLl.n; /* this should be the available clause */ return start->u.OtaLl.d; } static void remove_clause_from_index(yamop *header, LogUpdClause *cl) { yamop **prevp = &(header->u.Illss.l1); yamop *curp = header->u.Illss.l1; if (curp->u.OtaLl.d == cl) { yamop *newp = curp->u.OtaLl.n; newp->opc = curp->opc; *prevp = newp; } else { yamop *ocurp = NULL, *ocurp0 = curp; while (curp->u.OtaLl.d != cl) { ocurp = curp; curp = curp->u.OtaLl.n; } /* in case we were the last */ if (curp == header->u.Illss.l2) header->u.Illss.l2 = ocurp; if (ocurp != ocurp0) ocurp->opc = curp->opc; ocurp->u.OtILl.n = curp->u.OtaLl.n; ocurp->u.OtILl.block = curp->u.OtILl.block; } header->u.Illss.e--; #if DEBUG Yap_DirtyCps--; Yap_FreedCps++; #endif clean_ref_to_clause(cl); Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtILl); Yap_FreeCodeSpace((ADDR)curp); } static void remove_dirty_clauses_from_index(yamop *header) { LogUpdClause *cl; yamop *previouscurp; OPCODE endop = Yap_opcode(_trust_logical); yamop **prevp= &(header->u.Illss.l1), *curp = header->u.Illss.l1; OPCODE startopc = curp->opc; PredEntry *ap = curp->u.OtaLl.d->ClPred; if (ap->PredFlags & CountPredFlag) endop = Yap_opcode(_count_trust_logical); else if (ap->PredFlags & ProfiledPredFlag) endop = Yap_opcode(_profiled_trust_logical); while ((cl = curp->u.OtaLl.d) && (cl->ClFlags & ErasedMask)) { yamop *ocurp = curp; header->u.Illss.e--; #if DEBUG Yap_DirtyCps--; Yap_FreedCps++; #endif //if (ap->ModuleOfPred!=IDB_MODULE && !strcmp(RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE, "$lgt_send_to_obj_ne_")) // printf(" L %p %p %d %p\n", curp, curp->u.OtaLl.n, header->u.Illss.e, curp->opc); clean_ref_to_clause(cl); curp = curp->u.OtaLl.n; Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtaLl); Yap_FreeCodeSpace((ADDR)ocurp); if (ocurp == header->u.Illss.l2) { LogUpdIndex *clau = header->u.Illss.I; /* no clauses left */ if (clau->ClFlags & ErasedMask) { Yap_ErLogUpdIndex(clau); return; } header->u.Illss.l1 = header->u.Illss.l2 = NULL; header->u.Illss.s = header->u.Illss.e = 0; return; } } *prevp = curp; curp->opc = startopc; if (curp->opc == endop) return; if (!header->u.Illss.e) return; previouscurp = curp; curp = curp->u.OtaLl.n; while (TRUE) { if ((cl = curp->u.OtaLl.d)->ClFlags & ErasedMask) { yamop *ocurp = curp; header->u.Illss.e--; #if DEBUG Yap_DirtyCps--; Yap_FreedCps++; #endif clean_ref_to_clause(cl); if (curp->opc == endop) { previouscurp->opc = endop; previouscurp->u.OtILl.block = curp->u.OtILl.block; previouscurp->u.OtILl.n = NULL; header->u.Illss.l2 = previouscurp; Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtILl); Yap_FreeCodeSpace((ADDR)curp); return; } previouscurp->u.OtaLl.n = curp->u.OtaLl.n; curp = curp->u.OtaLl.n; Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtaLl); Yap_FreeCodeSpace((ADDR)ocurp); if (!header->u.Illss.e) return; } else { previouscurp = curp; if (curp->opc == endop) { curp->u.OtILl.n = NULL; return; } curp = curp->u.OtaLl.n; } } } static path_stack_entry * kill_clause(yamop *ipc, yamop *bg, yamop *lt, path_stack_entry *sp0, PredEntry *ap) { LogUpdIndex *blk; yamop *start; op_numbers op0; path_stack_entry *sp = sp0; while ((--sp)->flag != block_entry); blk = (LogUpdIndex *)(sp->uip.cle.block); start = blk->ClCode; op0 = Yap_op_from_opcode(start->opc); while (op0 == _lock_lu) { start = NEXTOP(start, p); op0 = Yap_op_from_opcode(start->opc); } while (op0 == _jump_if_nonvar) { start = NEXTOP(start, xll); op0 = Yap_op_from_opcode(start->opc); } if (op0 != _enter_lu_pred) { /* static code */ return kill_block(sp+1, ap); } /* weird case ????? */ if (!start->u.Illss.s){ /* ERROR */ Yap_Error(INTERNAL_ERROR, TermNil, "Illss.s == 0 %p", ipc); return sp; } if (start->u.Illss.s == 1) { /* we need to discover which clause is left and then die */ path_stack_entry *nsp; LogUpdClause *tgl = find_last_clause(start->u.Illss.l1); nsp = sp; while ((--nsp)->flag != block_entry); /* make us point straight at clause */ *sp->uip.cle.entry_code = tgl->ClCode; Yap_kill_iblock(sp->uip.cle.block, nsp->uip.cle.block, ap); return sp; } else { if ( #if MULTIPLE_STACKS blk->ClRefCount == 0 #else !(blk->ClFlags & InUseMask) #endif ) { remove_clause_from_index(start, ClauseCodeToLogUpdClause(bg)); } else { blk->ClFlags |= DirtyMask; } return sp; } } static path_stack_entry * expanda_block(path_stack_entry *sp, PredEntry *ap, ClauseDef *cls, int group1, yamop *alt, struct intermediates *cint) { while ((--sp)->flag != block_entry); Yap_kill_iblock(sp->uip.cle.block, NULL, ap); return sp; } static path_stack_entry * expandz_block(path_stack_entry *sp, PredEntry *ap, ClauseDef *cls, int group1, yamop *alt, struct intermediates *cint) { while ((--sp)->flag != block_entry); Yap_kill_iblock(sp->uip.cle.block, NULL, ap); return sp; } static LogUpdClause * lu_clause(yamop *ipc, PredEntry *ap) { if (ipc == FAILCODE) return NULL; if (ipc == (yamop *)(&(ap->OpcodeOfPred))) return NULL; return ClauseCodeToLogUpdClause(ipc); } static StaticClause * find_static_clause(PredEntry *ap, yamop *ipc) { StaticClause *cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause); while (ipc < cl->ClCode || ipc > (yamop *)((char *)cl+ cl->ClSize)) { cl = cl->ClNext; if (!cl) return NULL; } return cl; } static StaticClause * static_clause(yamop *ipc, PredEntry *ap, int trust) { CELL *p; if (ipc == FAILCODE) return NULL; if (ipc == (yamop*)(&(ap->OpcodeOfPred))) return NULL; if (ap->PredFlags & MegaClausePredFlag) return (StaticClause *)ipc; if (ap->PredFlags & TabledPredFlag) ipc = PREVOP(ipc,Otapl); p = (CELL *)ipc; if (trust) { return ClauseCodeToStaticClause(p); } else { op_numbers op = Yap_op_from_opcode(ipc->opc); UInt j; /* unbound call, so we cannot optimise instructions */ switch (op) { case _p_db_ref_x: case _p_float_x: j = Yap_regnotoreg(ipc->u.xl.x); break; case _get_list: j = Yap_regnotoreg(ipc->u.x.x); break; case _get_atom: j = Yap_regnotoreg(ipc->u.xc.x); break; case _get_float: j = Yap_regnotoreg(ipc->u.xd.x); break; case _get_struct: j = Yap_regnotoreg(ipc->u.xd.x); break; case _get_2atoms: case _get_3atoms: case _get_4atoms: case _get_5atoms: case _get_6atoms: return ClauseCodeToStaticClause(p); default: return find_static_clause(ap, ipc); } if (j == 1) /* must be the first instruction */ return ClauseCodeToStaticClause(p); return find_static_clause(ap, ipc); } return NULL; } static StaticClause * simple_static_clause(yamop *ipc, PredEntry *ap) { if (ipc == (yamop*)(&(ap->OpcodeOfPred))) return NULL; if (ipc == FAILCODE) return NULL; return ClauseCodeToStaticClause(ipc); } /* this code should be called when we jumped to clauses */ static path_stack_entry * kill_unsafe_block(path_stack_entry *sp, op_numbers op, PredEntry *ap, int first, int remove, ClauseDef *cls) { yamop *ipc; while ((--sp)->flag != block_entry); if (sp->uip.cle.entry_code == NULL) { /* we have reached the top */ Yap_RemoveIndexation(ap); return sp; } ipc = *sp->uip.cle.entry_code; if (Yap_op_from_opcode(ipc->opc) == op) { /* the new block was the current clause */ ClauseDef cld[2]; if (remove) { *sp->uip.cle.entry_code = FAILCODE; return sp; } if (ap->PredFlags & LogUpdatePredFlag) { struct intermediates intrs; LogUpdClause *lc = lu_clause(ipc, ap); if (first) { cld[0].Code = cls[0].Code; cld[1].Code = lc->ClCode; } else { cld[0].Code = lc->ClCode; cld[1].Code = cls[0].Code; } intrs.expand_block = NULL; *sp->uip.cle.entry_code = (yamop *)suspend_indexing(cld, cld+1, ap, &intrs); } else { /* static predicate, shouldn't do much, just suspend the code here */ *sp->uip.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode); return sp; } return sp; } /* we didn't have protection, should kill now */ return kill_block(sp+1, ap); } static int compacta_expand_clauses(yamop *ipc) { /* expand clauses so that you have a hole at the beginning */ /* we know that there is at least one element here */ yamop **start = (yamop **)(NEXTOP(ipc,sssllp)); yamop **ptr, **end; ptr = end = start+ipc->u.sssllp.s1; while (ptr > start) { yamop *next = *--ptr; if (next) *--end = next; } if (ptr != end) { while (end > start) { *--end = NULL; } return TRUE; } return FALSE; } static int compactz_expand_clauses(yamop *ipc) { /* expand clauses so that you have a hole at the beginning */ /* we know that there is at least one element here */ yamop **start = (yamop **)(NEXTOP(ipc,sssllp)); yamop **ptr, **end; end = start+ipc->u.sssllp.s1; ptr = start; while (ptr < end) { yamop *next = *ptr++; if (next) *start++ = next; } /* reset empty slots at end */ if (start != end) { while (start < end) { *start++ = NULL; } return TRUE; } return FALSE; } /* this code should be called when we jumped to clauses */ static yamop * add_to_expand_clauses(path_stack_entry **spp, yamop *ipc, ClauseDef *cls, PredEntry *ap, int first, struct intermediates *cint) { path_stack_entry *sp = *spp; yamop **clar; if (first) { do { clar = (yamop **)NEXTOP(ipc,sssllp); if (*clar == NULL || clar[0] == cls->Code) { while (*clar == NULL) clar++; if (clar[0] != cls->Code) { clar[-1] = cls->Code; ipc->u.sssllp.s2++; } return pop_path(spp, cls, ap, cint); } } while (compacta_expand_clauses(ipc)); } else { do { clar = (yamop **)NEXTOP(ipc,sssllp) + ipc->u.sssllp.s1; if (clar[-1] == NULL || clar[-1] == cls->Code) { while (*--clar == NULL); if (clar[0] != cls->Code) { clar[1] = cls->Code; ipc->u.sssllp.s2++; } return pop_path(spp, cls, ap, cint); } } while (compactz_expand_clauses(ipc)); } while ((--sp)->flag != block_entry); if (sp->uip.cle.entry_code) { *sp->uip.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode); } recover_ecls_block(ipc); return pop_path(spp, cls, ap, cint); } /* this code should be called when we jumped to clauses */ static void nullify_expand_clause(yamop *ipc, path_stack_entry *sp, ClauseDef *cls) { yamop **st = (yamop **)NEXTOP(ipc,sssllp); yamop **max = st+ipc->u.sssllp.s1; /* make sure we get rid of the reference */ while (st < max) { if (*st && *st == cls->Code) { *st = NULL; ipc->u.sssllp.s2--; break; } st++; } /* if the block has a single element */ if (ipc->u.sssllp.s2 == 1) { yamop **st = (yamop **)NEXTOP(ipc,sssllp); while ((--sp)->flag != block_entry); while (TRUE) { if (*st && *st != cls->Code) { *sp->uip.cle.entry_code = *st; recover_ecls_block(ipc); return; } st++; } } } static yamop * add_try(PredEntry *ap, ClauseDef *cls, yamop *next, struct intermediates *cint) { yamop *newcp; UInt size = (UInt)NEXTOP((yamop *)NULL,OtaLl); LogUpdClause *lcl = ClauseCodeToLogUpdClause(cls->Code); if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) { /* OOOPS, got in trouble, must do a siglongjmp and recover space */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_CP += size; #if DEBUG Yap_NewCps++; Yap_LiveCps++; #endif newcp->opc = Yap_opcode(_try_logical); newcp->u.OtaLl.s = ap->ArityOfPE; newcp->u.OtaLl.n = next; newcp->u.OtaLl.d = lcl; lcl->ClRefCount++; return newcp; } static yamop * add_trust(LogUpdIndex *icl, ClauseDef *cls, struct intermediates *cint) { yamop *newcp; UInt size = (UInt)NEXTOP((yamop *)NULL,OtILl); LogUpdClause *lcl = ClauseCodeToLogUpdClause(cls->Code); PredEntry *ap = lcl->ClPred; if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) { /* OOOPS, got in trouble, must do a siglongjmp and recover space */ save_machine_regs(); siglongjmp(cint->CompilerBotch,2); } Yap_LUIndexSpace_CP += size; #if DEBUG Yap_NewCps++; Yap_LiveCps++; #endif if (ap->PredFlags & CountPredFlag) newcp->opc = Yap_opcode(_count_trust_logical); else if (ap->PredFlags & ProfiledPredFlag) newcp->opc = Yap_opcode(_profiled_trust_logical); else newcp->opc = Yap_opcode(_trust_logical); newcp->u.OtILl.block = icl; newcp->u.OtILl.n = NULL; newcp->u.OtILl.d = lcl; lcl->ClRefCount++; return newcp; } static void add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, ClauseDef *cls) { /* last clause to experiment with */ PredEntry *ap = cint->CurrentPred; yamop *ipc = ap->cs.p_code.TrueCodeOfPred; int group1 = TRUE; yamop *alt = NULL; UInt current_arity = 0; LogUpdIndex *icl = NULL; sp = init_block_stack(sp, ipc, ap); /* try to refine the interval using the indexing code */ while (ipc != NULL) { op_numbers op = Yap_op_from_opcode(ipc->opc); switch(op) { case _try_logical: case _retry_logical: case _count_retry_logical: case _profiled_retry_logical: case _trust_logical: case _count_trust_logical: case _profiled_trust_logical: /* ERROR */ break; case _enter_lu_pred: ipc->u.Illss.s++; icl = ipc->u.Illss.I; if (first) { if (ap->PredFlags & CountPredFlag) ipc->u.Illss.l1->opc = Yap_opcode(_count_retry_logical); else if (ap->PredFlags & ProfiledPredFlag) ipc->u.Illss.l1->opc = Yap_opcode(_profiled_retry_logical); else ipc->u.Illss.l1->opc = Yap_opcode(_retry_logical); ipc->u.Illss.l1 = add_try(ap, cls, ipc->u.Illss.l1, cint); } else { /* just go to next instruction */ yamop *end = add_trust(icl, cls, cint), *old = ipc->u.Illss.l2; /* we used to have two clauses */ if (ap->PredFlags & CountPredFlag) old->opc = Yap_opcode(_count_retry_logical); else if (ap->PredFlags & ProfiledPredFlag) old->opc = Yap_opcode(_profiled_retry_logical); else old->opc = Yap_opcode(_retry_logical); old->u.OtaLl.n = end; old->u.OtaLl.s = ap->ArityOfPE; ipc->u.Illss.l2 = end; } ipc = pop_path(&sp, cls, ap, cint); break; case _try_clause: /* I cannot expand a predicate that starts on a variable, have to expand the index. */ if (first) { sp = expanda_block(sp, ap, cls, group1, alt, cint); ipc = pop_path(&sp, cls, ap, cint); } else { /* just go to next instruction */ ipc = NEXTOP(ipc,Otapl); } break; case _try_clause2: case _try_clause3: case _try_clause4: /* I cannot expand a predicate that starts on a variable, have to expand the index. */ if (first) { sp = expanda_block(sp, ap, cls, group1, alt, cint); ipc = pop_path(&sp, cls, ap, cint); } else { /* just go to next instruction */ ipc = NEXTOP(ipc,l); } break; case _retry: /* this clause had no indexing */ ipc = NEXTOP(ipc,Otapl); break; case _retry2: case _retry3: case _retry4: /* this clause had no indexing */ ipc = NEXTOP(ipc,l); break; /* instructions type l */ case _retry_me: /* should never be reached both for asserta */ group1 = FALSE; ipc = ipc->u.Otapl.d; break; case _try_me: if (first) { ipc = NEXTOP(ipc,Otapl); alt = ipc->u.Otapl.d; } else { ipc = ipc->u.Otapl.d; group1 = FALSE; } break; case _retry_profiled: case _count_retry: ipc = NEXTOP(ipc,Otapl); break; case _profiled_trust_me: case _trust_me: case _count_trust_me: group1 = FALSE; ipc = NEXTOP(ipc,Otapl); break; case _trust: sp = expandz_block(sp, ap, cls, group1, alt, cint); ipc = pop_path(&sp, cls, ap, cint); break; case _jump: sp = cross_block(sp, &ipc->u.l.l, ap, cint); /* just skip for now, but should worry about memory management */ ipc = ipc->u.l.l; break; case _jump_if_var: sp = push_path(sp, &(ipc->u.l.l), cls, cint); ipc = NEXTOP(ipc,l); break; case _jump_if_nonvar: sp = push_path(sp, &(ipc->u.xll.l2), cls, cint); sp = cross_block(sp, &ipc->u.xll.l1, ap, cint); ipc = ipc->u.xll.l1; break; /* instructions type EC */ case _try_in: /* we are done */ if (first) { sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { ipc = NEXTOP(ipc,l); } break; case _user_switch: ipc = ipc->u.lp.l; break; /* instructions type e */ case _switch_on_type: sp = push_path(sp, &(ipc->u.llll.l4), cls, cint); if (ap->PredFlags & LogUpdatePredFlag) { add_head_info(cls, 1); } else { add_info(cls, 1); } if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l1; current_arity = 2; move_next(cls, 1); if (nipc == FAILCODE) { /* jump straight to clause */ if (ap->PredFlags & LogUpdatePredFlag) { ipc->u.llll.l1 = cls->Code; } else { ipc->u.llll.l1 = cls->CurrentCode; } ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.llll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l2; move_next(cls, 1); if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l3; if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _switch_list_nl: sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); break; case _switch_on_arg_type: sp = push_path(sp, &(ipc->u.xllll.l4), cls, cint); if (ap->PredFlags & LogUpdatePredFlag) { add_head_info(cls, Yap_regtoregno(ipc->u.xllll.x)); } else { add_info(cls, Yap_regtoregno(ipc->u.xllll.x)); } if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l1; current_arity = 2; move_next(cls, Yap_regtoregno(ipc->u.xllll.x)); if (nipc == FAILCODE) { /* jump straight to clause */ if (ap->PredFlags & LogUpdatePredFlag) { ipc->u.xllll.l1 = cls->Code; } else { ipc->u.xllll.l1 = cls->CurrentCode; } ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.xllll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l2; move_next(cls, Yap_regtoregno(ipc->u.xllll.x)); if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l3; move_next(cls, Yap_regtoregno(ipc->u.xllll.x)); if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _switch_on_sub_arg_type: sp = push_path(sp, &(ipc->u.sllll.l4), cls, cint); add_arg_info(cls, ap, ipc->u.sllll.s+1); if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l1; current_arity = 2; skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity); if (nipc == FAILCODE) { /* jump straight to clause */ if (ap->PredFlags & LogUpdatePredFlag) { ipc->u.sllll.l1 = cls->Code; } else { ipc->u.sllll.l1 = cls->CurrentCode; } ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.sllll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l2; skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity); if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l3; skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity); if (nipc == FAILCODE) { /* need to expand the block */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _if_not_then: ipc = pop_path(&sp, cls, ap, cint); break; /* instructions type ollll */ case _switch_on_func: case _if_func: case _go_on_func: { FuncSwiEntry *fe; yamop *newpc; Functor f = (Functor)RepAppl(cls->Tag); if (op == _switch_on_func) { fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s); } else { fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s); } if (!IsExtensionFunctor(f)) { current_arity = ArityOfFunctor(f); } newpc = fe->u_f.labp; if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) { /* we found it */ ipc = pop_path(&sp, cls, ap, cint); } else if (newpc == FAILCODE) { /* oops, nothing there */ if (fe->Tag != f) { if (IsExtensionFunctor(f)) { sp = kill_unsafe_block(sp, op, ap, first, FALSE, cls); ipc = pop_path(&sp, cls, ap, cint); break; } if (table_fe_overflow(ipc, f)) { fe = expand_ftable(ipc, current_block(sp), cint, f); } fe->Tag = f; ipc->u.sssl.e++; } if (ap->PredFlags & LogUpdatePredFlag) { fe->u_f.labp = cls->Code; } else { fe->u_f.labp = cls->CurrentCode; } ipc = pop_path(&sp, cls, ap, cint); } else { yamop *newpc = fe->u_f.labp; sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint); sp = cross_block(sp, &(fe->u_f.labp), ap, cint); ipc = newpc; } } break; case _index_dbref: cls->Tag = cls->ucd.t_ptr; ipc = NEXTOP(ipc,e); break; case _index_blob: cls->Tag = Yap_Double_key(cls->ucd.t_ptr); ipc = NEXTOP(ipc,e); break; case _index_long: cls->Tag = Yap_Int_key(cls->ucd.t_ptr); ipc = NEXTOP(ipc,e); break; case _switch_on_cons: case _if_cons: case _go_on_cons: { AtomSwiEntry *ae; yamop *newpc; Term at = cls->Tag; if (op == _switch_on_cons) { ae = lookup_c_hash(at,ipc->u.sssl.l,ipc->u.sssl.s); } else { ae = lookup_c(at, ipc->u.sssl.l, ipc->u.sssl.s); } newpc = ae->u_a.labp; if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) { /* nothing more to do */ ipc = pop_path(&sp, cls, ap, cint); } else if (newpc == FAILCODE) { /* oops, nothing there */ if (ae->Tag != at) { if (table_ae_overflow(ipc, at)) { ae = expand_ctable(ipc, current_block(sp), cint, at); } ae->Tag = at; ipc->u.sssl.e++; } if (ap->PredFlags & LogUpdatePredFlag) { ae->u_a.labp = cls->Code; } else { ae->u_a.labp = cls->CurrentCode; } ipc = pop_path(&sp, cls, ap, cint); } else { yamop *newpc = ae->u_a.labp; sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint); sp = cross_block(sp, &(ae->u_a.labp), ap, cint); ipc = newpc; } } break; case _expand_clauses: ipc = add_to_expand_clauses(&sp, ipc, cls, ap, first, cint); break; case _expand_index: ipc = pop_path(&sp, cls, ap, cint); break; case _lock_lu: ipc = NEXTOP(ipc,p); break; case _unlock_lu: ipc = NEXTOP(ipc,e); break; case _op_fail: while ((--sp)->flag != block_entry); *sp->uip.cle.entry_code = cls->Code; ipc = pop_path(&sp, cls, ap, cint); break; default: sp = kill_unsafe_block(sp, op, ap, first, FALSE, cls); ipc = pop_path(&sp, cls, ap, cint); } } } void Yap_AddClauseToIndex(PredEntry *ap, yamop *beg, int first) { CACHE_REGS ClauseDef cl; /* first clause */ path_stack_entry *stack, *sp; int cb; struct intermediates cint; if (!(ap->PredFlags & LogUpdatePredFlag)) { if (ap->PredFlags & IndexedPredFlag) Yap_RemoveIndexation(ap); return; } cint.CurrentPred = ap; cint.expand_block = NULL; cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NIL; cint.term_depth = cint.last_index_new_depth = cint.last_depth_size = 0L; if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) { restore_machine_regs(); Yap_gcl(LOCAL_Error_Size, ap->ArityOfPE, ENV, CP); save_machine_regs(); } else if (cb == 2) { restore_machine_regs(); Yap_growheap(FALSE, LOCAL_Error_Size, NULL); save_machine_regs(); } else if (cb == 4) { restore_machine_regs(); Yap_growtrail(LOCAL_Error_Size, FALSE); save_machine_regs(); } if (cb) { Yap_RemoveIndexation(ap); return; } LOCAL_Error_Size = 0; LOCAL_ErrorMessage = NULL; #if DEBUG if (GLOBAL_Option['i' - 'a' + 1]) { Term tmod = ap->ModuleOfPred; if (!tmod) tmod = TermProlog; Yap_DebugPutc(LOCAL_c_error_stream,'+'); Yap_DebugPutc(LOCAL_c_error_stream,'\t'); Yap_DebugPlWrite(tmod); Yap_DebugPutc(LOCAL_c_error_stream,':'); if (ap->ModuleOfPred == IDB_MODULE) { Term t = Deref(ARG1); if (IsAtomTerm(t)) { Yap_DebugPlWrite(t); } else if (IsIntegerTerm(t)) { Yap_DebugPlWrite(t); } else { Functor f = FunctorOfTerm(t); Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } else { if (ap->ArityOfPE == 0) { Atom At = (Atom)ap->FunctorOfPred; Yap_DebugPlWrite(MkAtomTerm(At)); } else { Functor f = ap->FunctorOfPred; Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } Yap_DebugPutc(LOCAL_c_error_stream,'\n'); } #endif stack = (path_stack_entry *)TR; cl.Code = cl.CurrentCode = beg; sp = push_path(stack, NULL, &cl, &cint); add_to_index(&cint, first, sp, &cl); } static void contract_ftable(yamop *ipc, ClauseUnion *blk, PredEntry *ap, Functor f) { int n = ipc->u.sssl.s; FuncSwiEntry *fep; if (n > MIN_HASH_ENTRIES) { fep = lookup_f_hash(f, ipc->u.sssl.l, n); } else { fep = (FuncSwiEntry *)(ipc->u.sssl.l); while (fep->Tag != f) fep++; } fep->u_f.labp = FAILCODE; } static void contract_ctable(yamop *ipc, ClauseUnion *blk, PredEntry *ap, Term at) { int n = ipc->u.sssl.s; AtomSwiEntry *cep; if (n > MIN_HASH_ENTRIES) { cep = lookup_c_hash(at, ipc->u.sssl.l, n); } else { cep = (AtomSwiEntry *)(ipc->u.sssl.l); while (cep->Tag != at) cep++; } cep->u_a.labp = FAILCODE; } static void remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg, yamop *lt, struct intermediates *cint) { /* last clause to experiment with */ yamop *ipc = ap->cs.p_code.TrueCodeOfPred; if (ap->cs.p_code.NOfClauses == 1) { if (ap->PredFlags & IndexedPredFlag) { Yap_RemoveIndexation(ap); return; } ap->cs.p_code.TrueCodeOfPred = ap->cs.p_code.FirstClause; if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) { ap->OpcodeOfPred = Yap_opcode(_spy_pred); ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); #if defined(YAPOR) || defined(THREADS) } else if (ap->PredFlags & LogUpdatePredFlag && !(ap->PredFlags & ThreadLocalPredFlag) && ap->ModuleOfPred != IDB_MODULE) { ap->cs.p_code.TrueCodeOfPred = FAILCODE; ap->OpcodeOfPred = LOCKPRED_OPCODE; ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); #endif } else { ap->OpcodeOfPred = ap->cs.p_code.FirstClause->opc; ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred; } return; } sp = init_block_stack(sp, ipc, ap); /* try to refine the interval using the indexing code */ while (ipc != NULL) { op_numbers op = Yap_op_from_opcode(ipc->opc); switch(op) { case _retry_profiled: case _count_retry: ipc = NEXTOP(ipc, p); break; case _try_in: /* I cannot expand a predicate that starts on a variable, have to expand the index. */ if (IN_BETWEEN(bg,ipc->u.l.l,lt)) { sp = kill_clause(ipc, bg, lt, sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* just go to next instruction */ ipc = NEXTOP(ipc,l); } break; case _try_clause: case _retry: /* I cannot expand a predicate that starts on a variable, have to expand the index. */ if (IN_BETWEEN(bg,ipc->u.Otapl.d,lt)) { sp = kill_clause(ipc, bg, lt, sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* just go to next instruction */ ipc = NEXTOP(ipc,Otapl); } break; case _try_clause2: case _try_clause3: case _try_clause4: case _retry2: case _retry3: case _retry4: /* I cannot expand a predicate that starts on a variable, have to expand the index. */ if (IN_BETWEEN(bg,ipc->u.l.l,lt)) { sp = kill_clause(ipc, bg, lt, sp, ap); ipc = pop_path(&sp, cls, ap, cint); } else { /* just go to next instruction */ ipc = NEXTOP(ipc,l); } break; case _trust: if (IN_BETWEEN(bg,ipc->u.Otapl.d,lt)) { sp = kill_clause(ipc, bg, lt, sp, ap); } ipc = pop_path(&sp, cls, ap, cint); break; case _enter_lu_pred: ipc->u.Illss.s--; ipc->u.Illss.e++; #if DEBUG Yap_DirtyCps++; Yap_LiveCps--; #endif sp = kill_clause(ipc, bg, lt, sp, ap); ipc = pop_path(&sp, cls, ap, cint); break; /* instructions type l */ case _try_me: case _retry_me: sp = push_path(sp, &(ipc->u.Otapl.d), cls, cint); ipc = NEXTOP(ipc,Otapl); break; case _profiled_trust_me: case _trust_me: case _count_trust_me: ipc = NEXTOP(ipc,Otapl); break; case _jump: sp = cross_block(sp, &ipc->u.l.l, ap, cint); /* just skip for now, but should worry about memory management */ ipc = ipc->u.l.l; break; case _jump_if_var: sp = push_path(sp, &(ipc->u.l.l), cls, cint); ipc = NEXTOP(ipc,l); break; case _jump_if_nonvar: sp = push_path(sp, &(ipc->u.xll.l2), cls, cint); sp = cross_block(sp, &ipc->u.xll.l1, ap, cint); ipc = ipc->u.xll.l1; break; case _user_switch: ipc = ipc->u.lp.l; break; /* instructions type e */ case _switch_on_type: sp = push_path(sp, &(ipc->u.llll.l4), cls, cint); if (ap->PredFlags & LogUpdatePredFlag) { add_head_info(cls, 1); } else { add_info(cls, 1); } if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l1; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.llll.l1 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.llll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l2; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.llll.l2 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.llll.l3; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.llll.l3 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _switch_list_nl: sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); break; case _switch_on_arg_type: sp = push_path(sp, &(ipc->u.xllll.l4), cls, cint); if (ap->PredFlags & LogUpdatePredFlag) { add_head_info(cls, Yap_regtoregno(ipc->u.xllll.x)); } else { add_info(cls, Yap_regtoregno(ipc->u.xllll.x)); } if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l1; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.xllll.l1 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.xllll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l2; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.xllll.l2 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.xllll.l3; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.xllll.l3 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _switch_on_sub_arg_type: sp = push_path(sp, &(ipc->u.sllll.l4), cls, cint); add_arg_info(cls, ap, ipc->u.sllll.s+1); if (IsPairTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l1; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.sllll.l1 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* go on */ sp = cross_block(sp, &ipc->u.sllll.l1, ap, cint); ipc = nipc; } } else if (IsAtomOrIntTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l2; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.sllll.l2 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else if (IsApplTerm(cls->Tag)) { yamop *nipc = ipc->u.sllll.l3; if (IN_BETWEEN(bg,nipc,lt)) { /* jump straight to clause */ ipc->u.sllll.l3 = FAILCODE; ipc = pop_path(&sp, cls, ap, cint); } else { /* I do not have to worry about crossing a block here */ ipc = nipc; } } else { /* we can't separate into four groups, need to restart. */ sp = kill_block(sp, ap); ipc = pop_path(&sp, cls, ap, cint); } break; case _if_not_then: ipc = pop_path(&sp, cls, ap, cint); break; /* instructions type ollll */ case _switch_on_func: case _if_func: case _go_on_func: { FuncSwiEntry *fe; yamop *newpc; Functor f = (Functor)RepAppl(cls->Tag); if (op == _switch_on_func) { fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s); } else { fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s); } newpc = fe->u_f.labp; if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) { /* we found it */ ipc = pop_path(&sp, cls, ap, cint); } else if (newpc == FAILCODE) { ipc = pop_path(&sp, cls, ap, cint); } else if (IN_BETWEEN(bg,fe->u_f.Label,lt)) { /* oops, nothing there */ contract_ftable(ipc, current_block(sp), ap, f); ipc = pop_path(&sp, cls, ap, cint); } else { yamop *newpc = fe->u_f.labp; sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint); sp = cross_block(sp, &(fe->u_f.labp), ap, cint); ipc = newpc; } } break; case _index_dbref: cls->Tag = cls->ucd.t_ptr; ipc = NEXTOP(ipc,e); break; case _index_blob: cls->Tag = Yap_Double_key(cls->ucd.t_ptr); ipc = NEXTOP(ipc,e); break; case _index_long: cls->Tag = Yap_Int_key(cls->ucd.t_ptr); ipc = NEXTOP(ipc,e); break; case _switch_on_cons: case _if_cons: case _go_on_cons: { AtomSwiEntry *ae; yamop *newpc; Term at = cls->Tag; if (op == _switch_on_cons) { ae = lookup_c_hash(at,ipc->u.sssl.l,ipc->u.sssl.s); } else { ae = lookup_c(at, ipc->u.sssl.l, ipc->u.sssl.s); } newpc = ae->u_a.labp; if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) { /* we found it */ ipc = pop_path(&sp, cls, ap, cint); } else if (newpc == FAILCODE) { ipc = pop_path(&sp, cls, ap, cint); } else if (IN_BETWEEN(bg,ae->u_a.Label,lt)) { /* oops, nothing there */ contract_ctable(ipc, current_block(sp), ap, at); ipc = pop_path(&sp, cls, ap, cint); } else { yamop *newpc = ae->u_a.labp; sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint); sp = cross_block(sp, &(ae->u_a.labp), ap, cint); ipc = newpc; } } break; case _expand_index: ipc = pop_path(&sp, cls, ap, cint); break; case _expand_clauses: nullify_expand_clause(ipc, sp, cls); ipc = pop_path(&sp, cls, ap, cint); break; case _lock_lu: ipc = NEXTOP(ipc,p); break; default: if (IN_BETWEEN(bg,ipc,lt)) { sp = kill_unsafe_block(sp, op, ap, TRUE, TRUE, cls); } ipc = pop_path(&sp, cls, ap, cint); } } } /* clause is locked */ void Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) { CACHE_REGS ClauseDef cl; /* first clause */ path_stack_entry *stack, *sp; int cb; yamop *last; struct intermediates cint; if (ap->PredFlags & MegaClausePredFlag) { return; } cint.expand_block = NULL; cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NULL; if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) { restore_machine_regs(); Yap_gcl(LOCAL_Error_Size, ap->ArityOfPE, ENV, CP); save_machine_regs(); } else if (cb == 2) { restore_machine_regs(); Yap_growheap(FALSE, LOCAL_Error_Size, NULL); save_machine_regs(); } else if (cb == 4) { restore_machine_regs(); Yap_growtrail(LOCAL_Error_Size, FALSE); save_machine_regs(); } LOCAL_Error_Size = 0; LOCAL_ErrorMessage = NULL; cint.term_depth = cint.last_index_new_depth = cint.last_depth_size = 0L; if (cb) { /* cannot rely on the code */ if (ap->PredFlags & LogUpdatePredFlag) { Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap); } else { StaticIndex *cl; cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred); Yap_kill_iblock((ClauseUnion *)cl, NULL, ap); } return; } #if DEBUG if (GLOBAL_Option['i' - 'a' + 1]) { Term tmod = ap->ModuleOfPred; if (!tmod) tmod = TermProlog; Yap_DebugPutc(LOCAL_c_error_stream,'-'); Yap_DebugPutc(LOCAL_c_error_stream,'\t'); Yap_DebugPlWrite(tmod); Yap_DebugPutc(LOCAL_c_error_stream,':'); if (ap->ModuleOfPred != IDB_MODULE) { if (ap->ArityOfPE == 0) { Atom At = (Atom)ap->FunctorOfPred; Yap_DebugPlWrite(MkAtomTerm(At)); } else { Functor f = ap->FunctorOfPred; Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } else { if (ap->PredFlags & NumberDBPredFlag) { Int id = ap->src.IndxId; Yap_DebugPlWrite(MkIntegerTerm(id)); } else if (ap->PredFlags & AtomDBPredFlag) { Atom At = (Atom)ap->FunctorOfPred; Yap_DebugPlWrite(MkAtomTerm(At)); } else { Functor f = ap->FunctorOfPred; Atom At = NameOfFunctor(f); Yap_DebugPlWrite(MkAtomTerm(At)); Yap_DebugPutc(LOCAL_c_error_stream,'/'); Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f))); } } Yap_DebugPutc(LOCAL_c_error_stream,'\n'); } #endif stack = (path_stack_entry *)TR; if (ap->PredFlags & LogUpdatePredFlag) { LogUpdClause *c = ClauseCodeToLogUpdClause(beg); cl.Code = cl.CurrentCode = beg; last = (yamop *)((CODEADDR)c+c->ClSize); } else { StaticClause *c = ClauseCodeToStaticClause(beg); cl.Code = cl.CurrentCode = beg; last = (yamop *)((CODEADDR)c+c->ClSize); } sp = push_path(stack, NULL, &cl, &cint); if (ap->cs.p_code.NOfClauses == 0) { /* there was no indexing code */ #if defined(YAPOR) || defined(THREADS) if (ap->PredFlags & LogUpdatePredFlag && ap->ModuleOfPred != IDB_MODULE) { ap->cs.p_code.TrueCodeOfPred = FAILCODE; ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); } else { #endif ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = FAILCODE; #if defined(YAPOR) || defined(THREADS) } #endif ap->OpcodeOfPred = Yap_opcode(_op_fail); } else if (ap->PredFlags & IndexedPredFlag) { remove_from_index(ap, sp, &cl, beg, last, &cint); } else if (ap->cs.p_code.NOfClauses == 1) { ap->cs.p_code.TrueCodeOfPred = ap->cs.p_code.FirstClause; ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); } } static void store_clause_choice_point(Term t1, Term tb, Term tr, yamop *ipc, PredEntry *pe, yamop *ap_pc, yamop *cp_pc USES_REGS) { Term tpc = MkIntegerTerm((Int)ipc); Term tpe = MkIntegerTerm((Int)pe); CELL *tsp = ASP-5; choiceptr bptr = ((choiceptr)tsp)-1; tsp[0] = tpe; tsp[1] = tpc; tsp[2] = t1; tsp[3] = tb; tsp[4] = tr; bptr->cp_tr = TR; HB = bptr->cp_h = HR; #ifdef DEPTH_LIMIT bptr->cp_depth = DEPTH; #endif bptr->cp_b = B; bptr->cp_cp = cp_pc; bptr->cp_ap = ap_pc; bptr->cp_env = ENV; /* now, install the new YREG */ ASP = (CELL *)bptr; ASP[E_CB] = (CELL)bptr; B = bptr; #ifdef YAPOR SCH_set_load(B); #endif /* YAPOR */ SET_BB(bptr); } static void update_clause_choice_point(yamop *ipc, yamop *ap_pc USES_REGS) { Term tpc = MkIntegerTerm((Int)ipc); B->cp_args[1] = tpc; B->cp_h = HR; B->cp_ap = ap_pc; } static LogUpdClause * to_clause(yamop *ipc, PredEntry *ap) { if (ap->PredFlags & LogUpdatePredFlag) return lu_clause(ipc, ap); else if (ap->PredFlags & MegaClausePredFlag) return (LogUpdClause *)ipc; else return (LogUpdClause *)simple_static_clause(ipc, ap); } LogUpdClause * Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, yamop *cp_pc) { CACHE_REGS CELL *s_reg = NULL; Term t = TermNil; int blob_term = FALSE; choiceptr b0 = NULL; #if defined(YAPOR) || defined(THREADS) yamop **jlbl = NULL; #endif int lu_pred = ap->PredFlags & LogUpdatePredFlag; int unbounded = TRUE; if (ap->ModuleOfPred != IDB_MODULE) { if (ap->ArityOfPE) { CELL *tar = RepAppl(Deref(Terms[0])); UInt i; for (i = 1; i <= ap->ArityOfPE; i++) { XREGS[i] = tar[i]; } } } /* try to refine the interval using the indexing code */ while (ipc != NULL) { op_numbers op = Yap_op_from_opcode(ipc->opc); switch(op) { case _try_in: update_clause_choice_point(NEXTOP(ipc,l), ap_pc PASS_REGS); if (lu_pred) return lu_clause(ipc->u.l.l, ap); else return (LogUpdClause *)static_clause(ipc->u.l.l, ap, unbounded); break; case _try_clause: #if TABLING case _table_try: #endif if (b0 == NULL) store_clause_choice_point(Terms[0], Terms[1], Terms[2], NEXTOP(ipc,Otapl), ap, ap_pc, cp_pc PASS_REGS); else { B = b0; b0 = NULL; update_clause_choice_point(NEXTOP(ipc,Otapl), ap_pc PASS_REGS); } if (lu_pred) return lu_clause(ipc->u.Otapl.d, ap); else return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, unbounded); case _try_clause2: case _try_clause3: case _try_clause4: if (b0 == NULL) store_clause_choice_point(Terms[0], Terms[1], Terms[2], NEXTOP(ipc,l), ap, ap_pc, cp_pc PASS_REGS); else { B = b0; b0 = NULL; update_clause_choice_point(NEXTOP(ipc,l), ap_pc PASS_REGS); } if (lu_pred) return lu_clause(ipc->u.l.l, ap); else return (LogUpdClause *)static_clause(ipc->u.l.l, ap, unbounded); case _try_me: #if TABLING case _table_try_me: #endif if (b0 == NULL) store_clause_choice_point(Terms[0], Terms[1], Terms[2], ipc->u.Otapl.d, ap, ap_pc, cp_pc PASS_REGS); else { B = b0; b0 = NULL; update_clause_choice_point(ipc->u.Otapl.d, ap_pc PASS_REGS); } ipc = NEXTOP(ipc,Otapl); break; case _retry_profiled: case _count_retry: ipc = NEXTOP(ipc,p); break; case _retry: #if TABLING case _table_retry: #endif update_clause_choice_point(NEXTOP(ipc,Otapl),ap_pc PASS_REGS); if (lu_pred) return lu_clause(ipc->u.Otapl.d, ap); else return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, TRUE); case _retry2: case _retry3: case _retry4: update_clause_choice_point(NEXTOP(ipc,l),ap_pc PASS_REGS); if (lu_pred) return lu_clause(ipc->u.l.l, ap); else return (LogUpdClause *)static_clause(ipc->u.l.l, ap, TRUE); case _retry_me: update_clause_choice_point(ipc->u.Otapl.d,ap_pc PASS_REGS); ipc = NEXTOP(ipc,Otapl); break; case _trust: #if TABLING case _table_trust: #endif { while (POP_CHOICE_POINT(B->cp_b)) { POP_EXECUTE(); } } #ifdef YAPOR { choiceptr cut_pt; cut_pt = B->cp_b; CUT_prune_to(cut_pt); B = cut_pt; } #else B = B->cp_b; #endif /* YAPOR */ b0 = B; if (lu_pred) return lu_clause(ipc->u.Otapl.d, ap); else return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, TRUE); case _profiled_trust_me: case _trust_me: case _count_trust_me: #if TABLING case _table_trust_me: #endif b0 = B; { while (POP_CHOICE_POINT(B->cp_b)) { POP_EXECUTE(); } } #ifdef YAPOR { choiceptr cut_pt; cut_pt = B->cp_b; CUT_prune_to(cut_pt); B = cut_pt; } #else B = B->cp_b; #endif /* YAPOR */ ipc = NEXTOP(ipc,Otapl); break; case _enter_lu_pred: { LogUpdIndex *cl = ipc->u.Illss.I; PredEntry *ap = cl->ClPred; if (!cl) return NULL; /* in case the index is empty */ if (ap->LastCallOfPred != LUCALL_EXEC) { /* only increment time stamp if we are working on current time stamp */ if (ap->TimeStampOfPred >= TIMESTAMP_RESET) Yap_UpdateTimestamps(ap); ap->TimeStampOfPred++; /* fprintf(stderr,"R %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/ ap->LastCallOfPred = LUCALL_EXEC; } *--ASP = MkIntegerTerm(ap->TimeStampOfPred); /* indicate the indexing code is being used */ #if MULTIPLE_STACKS /* just store a reference */ INC_CLREF_COUNT(cl); TRAIL_CLREF(cl); #else if (!(cl->ClFlags & InUseMask)) { cl->ClFlags |= InUseMask; TRAIL_CLREF(cl); } #endif } ipc = ipc->u.Illss.l1; break; case _try_logical: if (b0 == NULL) store_clause_choice_point(Terms[0], Terms[1], Terms[2], ipc->u.OtaLl.n, ap, ap_pc, cp_pc PASS_REGS); else { B = b0; b0 = NULL; update_clause_choice_point(ipc->u.OtaLl.n, ap_pc PASS_REGS); } { UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]); if (!VALID_TIMESTAMP(timestamp, ipc->u.OtaLl.d)) { /* jump to next instruction */ ipc = ipc->u.OtaLl.n; break; } } return ipc->u.OtaLl.d; case _retry_logical: case _profiled_retry_logical: case _count_retry_logical: { UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]); if (!VALID_TIMESTAMP(timestamp, ipc->u.OtaLl.d)) { /* jump to next instruction */ ipc = ipc->u.OtaLl.n; break; } } update_clause_choice_point(ipc->u.OtaLl.n,ap_pc PASS_REGS); return ipc->u.OtaLl.d; #if TABLING case _table_try_single: return (LogUpdClause *)ClauseCodeToStaticClause(ipc); #endif case _trust_logical: case _count_trust_logical: case _profiled_trust_logical: { UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]); LogUpdIndex *cl = ipc->u.OtILl.block; LogUpdClause *newpc; if (!VALID_TIMESTAMP(timestamp, ipc->u.OtILl.d)) { /* jump to next instruction */ newpc = NULL; } else { newpc = ipc->u.OtILl.d; } #if MULTIPLE_STACKS DEC_CLREF_COUNT(cl); B->cp_tr--; TR--; /* actually get rid of the code */ if (cl->ClRefCount == 0 && cl->ClFlags & (ErasedMask|DirtyMask)) { /* I am the last one using this clause, hence I don't need a lock to dispose of it. But on the other hand I need to make sure the clause is still there when I am back. */ LogUpdClause *lcl = ipc->u.OtILl.d; if (newpc) { if (lcl->ClRefCount == 1) { /* make sure the clause isn't destroyed */ /* always add an extra reference */ INC_CLREF_COUNT(lcl); TRAIL_CLREF(lcl); B->cp_tr = TR; } } if (cl->ClFlags & ErasedMask) { Yap_ErLogUpdIndex(cl); } else { Yap_CleanUpIndex(cl); } } #else if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && B->cp_tr != B->cp_b->cp_tr) { B->cp_tr--; TR--; cl->ClFlags &= ~InUseMask; /* next, recover space for the indexing code if it was erased */ if (cl->ClFlags & (ErasedMask|DirtyMask)) { LogUpdClause *lcl = ipc->u.OtILl.d; /* make sure we don't erase the clause we are jumping to, notice that ErLogUpdIndex may remove several references in one go. Notice we only need to do this if we´ re jumping to the clause. */ if (newpc && !(lcl->ClFlags & (DirtyMask|InUseMask))) { lcl->ClFlags |= InUseMask; TRAIL_CLREF(lcl); } if (cl->ClFlags & ErasedMask) { Yap_ErLogUpdIndex(cl); } else { Yap_CleanUpIndex(cl); } } } #endif { while (POP_CHOICE_POINT(B->cp_b)) { POP_EXECUTE(); } } #ifdef YAPOR { choiceptr cut_pt; cut_pt = B->cp_b; CUT_prune_to(cut_pt); B = cut_pt; } #else B = B->cp_b; #endif /* YAPOR */ b0 = B; return newpc; } case _jump: ipc = ipc->u.l.l; break; case _jump_if_var: { Term t = Deref(ARG1); if (IsVarTerm(t)) { SET_JLBL(l.l); ipc = ipc->u.l.l; } else { ipc = NEXTOP(ipc,l); } } break; case _jump_if_nonvar: { Term t = Deref(XREGS[arg_from_x(ipc->u.xll.x)]); if (!IsVarTerm(t)) { SET_JLBL(xll.l1); ipc = ipc->u.xll.l1; } else { ipc = NEXTOP(ipc,xll); } } break; case _user_switch: ipc = ipc->u.lp.l; break; /* instructions type e */ case _switch_on_type: t = Deref(ARG1); blob_term = FALSE; if (IsVarTerm(t)) { SET_JLBL(llll.l4); ipc = ipc->u.llll.l4; } else if (IsPairTerm(t)) { unbounded = FALSE; SET_JLBL(llll.l1); ipc = ipc->u.llll.l1; S = s_reg = RepPair(t); } else if (IsAtomOrIntTerm(t)) { SET_JLBL(llll.l2); ipc = ipc->u.llll.l2; } else { SET_JLBL(llll.l3); ipc = ipc->u.llll.l3; S = RepAppl(t); } break; case _switch_list_nl: t = Deref(ARG1); blob_term = FALSE; if (IsVarTerm(t)) { SET_JLBL(ollll.l4); ipc = ipc->u.ollll.l4; } else if (IsPairTerm(t)) { unbounded = FALSE; SET_JLBL(ollll.l1); ipc = ipc->u.ollll.l1; S = s_reg = RepPair(t); } else if (t == TermNil) { unbounded = FALSE; SET_JLBL(ollll.l2); ipc = ipc->u.ollll.l2; } else { SET_JLBL(ollll.l3); ipc = ipc->u.ollll.l3; S = RepAppl(t); } break; case _switch_on_arg_type: t = Deref(XREGS[arg_from_x(ipc->u.xllll.x)]); blob_term = FALSE; if (IsVarTerm(t)) { SET_JLBL(xllll.l4); ipc = ipc->u.xllll.l4; } else if (IsPairTerm(t)) { unbounded = FALSE; SET_JLBL(xllll.l1); ipc = ipc->u.xllll.l1; S = s_reg = RepPair(t); } else if (IsAtomOrIntTerm(t)) { SET_JLBL(xllll.l2); ipc = ipc->u.xllll.l2; } else { SET_JLBL(xllll.l3); ipc = ipc->u.xllll.l3; S = RepAppl(t); } break; case _switch_on_sub_arg_type: t = Deref(s_reg[ipc->u.sllll.s]); blob_term = FALSE; if (IsVarTerm(t)) { SET_JLBL(sllll.l4); ipc = ipc->u.sllll.l4; } else if (IsPairTerm(t)) { unbounded = FALSE; SET_JLBL(sllll.l1); S = s_reg = RepPair(t); ipc = ipc->u.sllll.l1; } else if (IsAtomOrIntTerm(t)) { SET_JLBL(sllll.l2); ipc = ipc->u.sllll.l2; } else { SET_JLBL(sllll.l3); ipc = ipc->u.sllll.l3; S = RepAppl(t); } break; case _if_not_then: t = Deref(ARG1); blob_term = FALSE; if (IsVarTerm(t)) { SET_JLBL(clll.l3); ipc = ipc->u.clll.l3; } else if (!IsVarTerm(t) && t != ipc->u.clll.c) { SET_JLBL(clll.l1); ipc = ipc->u.clll.l1; } else { SET_JLBL(clll.l2); ipc = ipc->u.clll.l2; } break; /* instructions type ollll */ case _switch_on_func: case _if_func: case _go_on_func: { FuncSwiEntry *fe; Functor f; unbounded = FALSE; s_reg = RepAppl(t); f = (Functor)s_reg[0]; s_reg++; S = s_reg; if (op == _switch_on_func) { fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s); } else { fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s); } #if defined(YAPOR) || defined(THREADS) jlbl = &(fe->u_f.labp); #endif ipc = fe->u_f.labp; } break; case _index_dbref: t = AbsAppl(s_reg-1); blob_term = FALSE; ipc = NEXTOP(ipc,e); break; case _index_blob: t = Yap_DoubleP_key(s_reg); blob_term = TRUE; ipc = NEXTOP(ipc,e); break; case _index_long: t = Yap_IntP_key(s_reg); blob_term = TRUE; ipc = NEXTOP(ipc,e); break; case _switch_on_cons: case _if_cons: case _go_on_cons: { AtomSwiEntry *ae; unbounded = FALSE; if (op == _switch_on_cons) { ae = lookup_c_hash(t, ipc->u.sssl.l, ipc->u.sssl.s); } else { ae = lookup_c(t, ipc->u.sssl.l, ipc->u.sssl.s); } #if defined(YAPOR) || defined(THREADS) jlbl = &(ae->u_a.labp); #endif ipc = ae->u_a.labp; } break; case _expand_index: case _expand_clauses: if (blob_term) { /* protect garbage collector */ XREGS[ap->ArityOfPE+1] = (CELL)&XREGS[ap->ArityOfPE+1]; XREGS[ap->ArityOfPE+2] = TermNil; } else { XREGS[ap->ArityOfPE+1] = (CELL)s_reg; XREGS[ap->ArityOfPE+2] = t; } XREGS[ap->ArityOfPE+3] = Terms[0]; XREGS[ap->ArityOfPE+4] = Terms[1]; XREGS[ap->ArityOfPE+5] = Terms[2]; #if defined(YAPOR) || defined(THREADS) if (!same_lu_block(jlbl, ipc)) { ipc = *jlbl; break; } #endif ipc = ExpandIndex(ap, 5, cp_pc PASS_REGS); if (!blob_term) { /* protect garbage collector */ s_reg = (CELL *)XREGS[ap->ArityOfPE+1]; t = XREGS[ap->ArityOfPE+2]; } blob_term = FALSE; Terms[0] = XREGS[ap->ArityOfPE+3]; Terms[1] = XREGS[ap->ArityOfPE+4]; Terms[2] = XREGS[ap->ArityOfPE+5]; break; case _undef_p: return NULL; case _lock_lu: ipc = NEXTOP(ipc,p); break; #if THREADS case _thread_local: ap = Yap_GetThreadPred(ap PASS_REGS); ipc = ap->CodeOfPred; break; #endif case _spy_pred: case _lock_pred: if ((ap->PredFlags & IndexedPredFlag) || ap->cs.p_code.NOfClauses <= 1) { ipc = ap->cs.p_code.TrueCodeOfPred; break; } case _index_pred: if (blob_term) { /* protect garbage collector */ XREGS[ap->ArityOfPE+1] = (CELL)&XREGS[ap->ArityOfPE+1]; XREGS[ap->ArityOfPE+2] = TermNil; } else { XREGS[ap->ArityOfPE+1] = (CELL)s_reg; XREGS[ap->ArityOfPE+2] = t; } XREGS[ap->ArityOfPE+3] = Terms[0]; XREGS[ap->ArityOfPE+4] = Terms[1]; XREGS[ap->ArityOfPE+5] = Terms[2]; Yap_IPred(ap, 5, cp_pc); ipc = ap->cs.p_code.TrueCodeOfPred; if (!blob_term) { /* protect garbage collector */ s_reg = (CELL *)XREGS[ap->ArityOfPE+1]; t = XREGS[ap->ArityOfPE+2]; } Terms[0] = XREGS[ap->ArityOfPE+3]; Terms[1] = XREGS[ap->ArityOfPE+4]; Terms[2] = XREGS[ap->ArityOfPE+5]; break; case _op_fail: if (ipc == FAILCODE) return NULL; default: if (b0) { { while (POP_CHOICE_POINT(B->cp_b)) { POP_EXECUTE(); } } #ifdef YAPOR { choiceptr cut_pt; cut_pt = B->cp_b; CUT_prune_to(cut_pt); B = cut_pt; } #else B = B->cp_b; #endif /* YAPOR */ /* I did a trust */ } if (op == _op_fail) return NULL; if (lu_pred) return lu_clause(ipc, ap); else return (LogUpdClause *)static_clause(ipc, ap, unbounded); } } if (b0) { /* I did a trust */ { while (POP_CHOICE_POINT(B->cp_b)) { POP_EXECUTE(); } } #ifdef YAPOR { choiceptr cut_pt; cut_pt = B->cp_b; CUT_prune_to(cut_pt); B = cut_pt; } #else B = B->cp_b; #endif /* YAPOR */ } return NULL; } LogUpdClause * Yap_NthClause(PredEntry *ap, Int ncls) { CACHE_REGS yamop *ipc = ap->cs.p_code.TrueCodeOfPred, *alt = NULL; #if defined(YAPOR) || defined(THREADS) yamop **jlbl = NULL; #endif /* search every clause */ if (ncls > ap->cs.p_code.NOfClauses) return NULL; else if (ncls == 1) return to_clause(ap->cs.p_code.FirstClause,ap); else if (ap->PredFlags & MegaClausePredFlag) { MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause); /* fast access to nth element, all have same size */ return (LogUpdClause *)((char *)mcl->ClCode+(ncls-1)*mcl->ClItemSize); } else if (ncls == ap->cs.p_code.NOfClauses) { return to_clause(ap->cs.p_code.LastClause,ap); } else if (ncls < 0) return NULL; if (ap->ModuleOfPred != IDB_MODULE) { if (ap->ArityOfPE) { UInt i; for (i = 1; i <= ap->ArityOfPE; i++) { XREGS[i] = MkVarTerm(); } } } else { ARG2 = MkVarTerm(); } while (TRUE) { op_numbers op = Yap_op_from_opcode(ipc->opc); switch(op) { case _try_in: if (ncls == 1) return to_clause(ipc->u.l.l, ap); ncls--; ipc = NEXTOP(ipc,l); break; case _retry_profiled: case _count_retry: ipc = NEXTOP(ipc,p); case _try_clause: case _retry: if (ncls == 1) return to_clause(ipc->u.Otapl.d, ap); else if (alt == NULL) { ncls --; /* get there in a fell swoop */ if (ap->PredFlags & ProfiledPredFlag) { if (ap->PredFlags & CountPredFlag) { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP(NEXTOP((yamop *)NULL,Otapl),p),p)); } else { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,Otapl),p)); } } else if (ap->PredFlags & CountPredFlag) { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,Otapl),p)); } else { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP((yamop *)NULL,Otapl)); } return to_clause(ipc->u.Otapl.d, ap); } else { ncls--; } ipc = NEXTOP(ipc,Otapl); break; case _try_clause2: case _try_clause3: case _try_clause4: case _retry2: case _retry3: case _retry4: if (ncls == 1) return to_clause(ipc->u.l.l, ap); else if (alt == NULL) { ncls --; /* get there in a fell swoop */ if (ap->PredFlags & ProfiledPredFlag) { if (ap->PredFlags & CountPredFlag) { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP(NEXTOP((yamop *)NULL,l),p),p)); } else { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,l),p)); } } else if (ap->PredFlags & CountPredFlag) { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,l),p)); } else { ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP((yamop *)NULL,l)); } return to_clause(ipc->u.l.l, ap); } else { ncls--; } ipc = NEXTOP(ipc,l); break; case _trust: if (ncls == 1) return to_clause(ipc->u.l.l,ap); ncls--; ipc = alt; break; case _try_me: case _retry_me: alt = ipc->u.Otapl.d; ipc = NEXTOP(ipc,Otapl); break; case _profiled_trust_me: case _trust_me: case _count_trust_me: alt = NULL; ipc = NEXTOP(ipc,Otapl); break; case _try_logical: case _retry_logical: case _count_retry_logical: case _profiled_retry_logical: if (VALID_TIMESTAMP(ap->TimeStampOfPred, ipc->u.OtaLl.d)) { if (ncls == 1) return ipc->u.OtaLl.d; ncls--; } ipc = ipc->u.OtaLl.n; break; case _trust_logical: case _count_trust_logical: case _profiled_trust_logical: if (VALID_TIMESTAMP(ap->TimeStampOfPred, ipc->u.OtILl.d)) { if (ncls == 1) return ipc->u.OtILl.d; } return NULL; case _enter_lu_pred: SET_JLBL(Illss.l1); ipc = ipc->u.Illss.l1; break; case _lock_lu: ipc = NEXTOP(ipc,p); break; case _jump: SET_JLBL(l.l); ipc = ipc->u.l.l; break; case _jump_if_var: SET_JLBL(l.l); ipc = ipc->u.l.l; break; case _jump_if_nonvar: ipc = NEXTOP(ipc,xll); break; case _user_switch: SET_JLBL(l.l); ipc = ipc->u.lp.l; break; /* instructions type e */ case _switch_on_type: SET_JLBL(llll.l4); ipc = ipc->u.llll.l4; break; case _switch_list_nl: SET_JLBL(ollll.l4); ipc = ipc->u.ollll.l4; break; case _switch_on_arg_type: SET_JLBL(xllll.l4); ipc = ipc->u.xllll.l4; break; case _switch_on_sub_arg_type: SET_JLBL(sllll.l4); ipc = ipc->u.sllll.l4; break; case _if_not_then: SET_JLBL(clll.l3); ipc = ipc->u.clll.l3; break; case _expand_index: case _expand_clauses: #if defined(YAPOR) || defined(THREADS) if (*jlbl != (yamop *)&(ap->cs.p_code.ExpandCode)) { ipc = *jlbl; break; } #endif ipc = ExpandIndex(ap, 0, CP PASS_REGS); break; case _op_fail: ipc = alt; break; case _lock_pred: case _index_pred: case _spy_pred: Yap_IPred(ap, 0, CP); ipc = ap->cs.p_code.TrueCodeOfPred; break; case _undef_p: default: return NULL; } } } void Yap_CleanUpIndex(LogUpdIndex *blk) { /* just compact the code */ yamop *start = blk->ClCode; op_numbers op = Yap_op_from_opcode(start->opc); blk->ClFlags &= ~DirtyMask; while (op == _lock_lu) { start = NEXTOP(start, p); op = Yap_op_from_opcode(start->opc); } while (op == _jump_if_nonvar) { start = NEXTOP(start, xll); op = Yap_op_from_opcode(start->opc); } remove_dirty_clauses_from_index(start); }