1 /*************************************************************************
2 * *
3 * Yap Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: index.c *
12 * comments: Indexing a Prolog predicate *
13 * *
14 * Last rev: $Date: 2008-08-07 20:51:21 $,$Author: vsc $ *
15 * $Log: not supported by cvs2svn $
16 * Revision 1.202 2008/07/11 17:02:07 vsc
17 * fixes by Bart and Tom: mostly libraries but nasty one in indexing
18 * compilation.
19 *
20 * Revision 1.201 2008/05/10 23:24:11 vsc
21 * fix threads and LU
22 *
23 * Revision 1.200 2008/04/16 17:16:47 vsc
24 * make static_clause only commit to a lause if it is sure that is the true
25 * clause. Otherwise, search for the clause.
26 *
27 * Revision 1.199 2008/04/14 21:20:35 vsc
28 * fixed a bug in static_clause (thanks to Jose Santos)
29 *
30 * Revision 1.198 2008/03/25 16:45:53 vsc
31 * make or-parallelism compile again
32 *
33 * Revision 1.197 2008/02/14 14:35:13 vsc
34 * fixes for indexing code.
35 *
36 * Revision 1.196 2008/01/30 10:35:43 vsc
37 * fix indexing in 64 bits (it would split ints from atoms :( ).
38 *
39 * Revision 1.195 2008/01/24 10:20:42 vsc
40 * clause should not try to discover who is fail.
41 *
42 * Revision 1.194 2008/01/24 00:11:59 vsc
43 * garbage collector was not asking for space.
44 * avoid 0 sized calls to mmap.
45 *
46 * Revision 1.193 2008/01/23 17:57:46 vsc
47 * valgrind it!
48 * enable atom garbage collection.
49 *
50 * Revision 1.192 2007/11/26 23:43:08 vsc
51 * fixes to support threads and assert correctly, even if inefficiently.
52 *
53 * Revision 1.191 2007/11/08 15:52:15 vsc
54 * fix some bugs in new dbterm code.
55 *
56 * Revision 1.190 2007/11/07 09:25:27 vsc
57 * speedup meta-calls
58 *
59 * Revision 1.189 2007/11/06 17:02:12 vsc
60 * compile ground terms away.
61 *
62 * Revision 1.188 2007/10/28 11:23:40 vsc
63 * fix overflow
64 *
65 * Revision 1.187 2007/09/22 08:38:05 vsc
66 * nb_ extra stuff plus an indexing overflow fix.
67 *
68 * Revision 1.186 2007/06/20 13:48:45 vsc
69 * fix bug in index emulator
70 *
71 * Revision 1.185 2007/05/02 11:01:37 vsc
72 * get rid of type punning warnings.
73 *
74 * Revision 1.184 2007/03/26 15:18:43 vsc
75 * debugging and clause/3 over tabled predicates would kill YAP.
76 *
77 * Revision 1.183 2007/03/21 23:23:46 vsc
78 * fix excessive trail cleaning in gc tr overflow.
79 *
80 * Revision 1.182 2007/01/28 14:26:36 vsc
81 * WIN32 support
82 *
83 * Revision 1.181 2007/01/08 08:27:19 vsc
84 * fix restore (Trevor)
85 * make indexing a bit faster on IDB
86 *
87 * Revision 1.180 2006/12/27 01:32:37 vsc
88 * diverse fixes
89 *
90 * Revision 1.179 2006/11/27 17:42:02 vsc
91 * support for UNICODE, and other bug fixes.
92 *
93 * Revision 1.178 2006/11/21 16:21:31 vsc
94 * fix I/O mess
95 * fix spy/reconsult mess
96 *
97 * Revision 1.177 2006/11/15 00:13:36 vsc
98 * fixes for indexing code.
99 *
100 * Revision 1.176 2006/11/08 01:53:08 vsc
101 * avoid generating suspensions on static code.
102 *
103 * Revision 1.175 2006/11/06 18:35:04 vsc
104 * 1estranha
105 *
106 * Revision 1.174 2006/10/25 02:31:07 vsc
107 * fix emulation of trust_logical
108 *
109 * Revision 1.173 2006/10/18 13:47:31 vsc
110 * index.c implementation of trust_logical was decrementing the wrong
111 * cp_tr
112 *
113 * Revision 1.172 2006/10/16 17:12:48 vsc
114 * fixes for threaded version.
115 *
116 * Revision 1.171 2006/10/11 14:53:57 vsc
117 * fix memory leak
118 * fix overflow handling
119 * VS: ----------------------------------------------------------------------
120 *
121 * Revision 1.170 2006/10/10 14:08:16 vsc
122 * small fixes on threaded implementation.
123 *
124 * Revision 1.169 2006/09/20 20:03:51 vsc
125 * improve indexing on floats
126 * fix sending large lists to DB
127 *
128 * Revision 1.168 2006/05/16 18:37:30 vsc
129 * WIN32 fixes
130 * compiler bug fixes
131 * extend interface
132 *
133 * Revision 1.167 2006/05/02 16:44:11 vsc
134 * avoid uninitialised memory at overflow.
135 *
136 * Revision 1.166 2006/05/02 16:39:06 vsc
137 * bug in indexing code
138 * fix warning messages for write.c
139 *
140 * Revision 1.165 2006/04/27 17:04:08 vsc
141 * don't use <= to compare with block top (libc may not have block header).
142 *
143 * Revision 1.164 2006/04/27 14:10:36 rslopes
144 * *** empty log message ***
145 *
146 * Revision 1.163 2006/04/20 15:28:08 vsc
147 * more graph stuff.
148 *
149 * Revision 1.162 2006/04/12 18:56:50 vsc
150 * fix bug in clause: a trust_me followed by a try should be implemented by
151 * reusing the choice-point.
152 *
153 * Revision 1.161 2006/04/05 00:16:54 vsc
154 * Lots of fixes (check logfile for details
155 *
156 * Revision 1.160 2006/03/24 17:13:41 rslopes
157 * New update to BEAM engine.
158 * BEAM now uses YAP Indexing (JITI)
159 *
160 * Revision 1.159 2006/03/22 20:07:28 vsc
161 * take better care of zombies
162 *
163 * Revision 1.158 2006/03/21 21:30:54 vsc
164 * avoid looking around when expanding for statics too.
165 *
166 * Revision 1.157 2006/03/21 19:20:34 vsc
167 * fix fix on index expansion
168 *
169 * Revision 1.156 2006/03/21 17:11:39 vsc
170 * prevent breakage
171 *
172 * Revision 1.155 2006/03/21 15:06:35 vsc
173 * fixes to handle expansion of dyn amic predicates more efficiently.
174 *
175 * Revision 1.154 2006/03/20 19:51:43 vsc
176 * fix indexing and tabling bugs
177 *
178 * Revision 1.153 2006/02/22 11:55:36 vsc
179 * indexing code would get confused about size of float/1, db_reference1.
180 *
181 * Revision 1.152 2006/02/19 02:55:46 vsc
182 * disable indexing on bigints
183 *
184 * Revision 1.151 2006/01/16 02:57:51 vsc
185 * fix bug with very large integers
186 * fix bug where indexing code was looking at code after a cut.
187 *
188 * Revision 1.150 2005/12/23 00:20:13 vsc
189 * updates to gprof
190 * support for __POWER__
191 * Try to saveregs before siglongjmp.
192 *
193 * Revision 1.149 2005/12/17 03:25:39 vsc
194 * major changes to support online event-based profiling
195 * improve error discovery and restart on scanner.
196 *
197 * Revision 1.148 2005/11/24 15:33:52 tiagosoares
198 * removed some compilation warnings related to the cut-c code
199 *
200 * Revision 1.147 2005/11/18 18:48:52 tiagosoares
201 * support for executing c code when a cut occurs
202 *
203 * Revision 1.146 2005/10/29 02:21:47 vsc
204 * people should be able to disable indexing.
205 *
206 * Revision 1.145 2005/09/08 22:06:44 rslopes
207 * BEAM for YAP update...
208 *
209 * Revision 1.144 2005/08/17 18:48:35 vsc
210 * fix bug in processing overflows of expand_clauses.
211 *
212 * Revision 1.143 2005/08/02 03:09:50 vsc
213 * fix debugger to do well nonsource predicates.
214 *
215 * Revision 1.142 2005/08/01 15:40:37 ricroc
216 * TABLING NEW: better support for incomplete tabling
217 *
218 * Revision 1.141 2005/07/19 16:54:20 rslopes
219 * fix for older compilers...
220 *
221 * Revision 1.140 2005/07/18 17:41:16 vsc
222 * Yap should respect single argument indexing.
223 *
224 * Revision 1.139 2005/07/06 19:33:53 ricroc
225 * TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
226 *
227 * Revision 1.138 2005/07/05 18:32:32 vsc
228 * ifix some wierd cases in indexing code:
229 * would not look at next argument
230 * problem with pvar as last clause (R Camacho).
231 *
232 * Revision 1.137 2005/06/04 07:27:34 ricroc
233 * long int support for tabling
234 *
235 * Revision 1.136 2005/06/03 08:26:32 ricroc
236 * float support for tabling
237 *
238 * Revision 1.135 2005/06/01 20:25:23 vsc
239 * == and \= should not need a choice-point in ->
240 *
241 * Revision 1.134 2005/06/01 16:42:30 vsc
242 * put switch_list_nl back
243 *
244 * Revision 1.133 2005/06/01 14:02:50 vsc
245 * get_rid of try_me?, retry_me? and trust_me? instructions: they are not
246 * significantly used nowadays.
247 *
248 * Revision 1.132 2005/05/31 20:04:17 vsc
249 * fix cleanup of expand_clauses: make sure we have everything with NULL afterwards.
250 *
251 * Revision 1.131 2005/05/31 19:42:27 vsc
252 * insert some more slack for indices in LU
253 * Use doubly linked list for LU indices so that updating is less cumbersome.
254 *
255 * Revision 1.130 2005/05/31 04:46:06 vsc
256 * fix expand_index on tabled code.
257 *
258 * Revision 1.129 2005/05/31 02:15:53 vsc
259 * fix SYSTEM_ERROR messages
260 *
261 * Revision 1.128 2005/05/30 05:26:49 vsc
262 * fix tabling
263 * allow atom gc again for now.
264 *
265 * Revision 1.127 2005/05/27 21:44:00 vsc
266 * Don't try to mess with sequences that don't end with a trust.
267 * A fix for the atom garbage collector actually ignore floats ;-).
268 *
269 * Revision 1.126 2005/05/25 18:58:37 vsc
270 * fix another bug in nth_instance, thanks to Pat Caldon
271 *
272 * Revision 1.125 2005/04/28 14:50:45 vsc
273 * clause should always deref before testing type
274 *
275 * Revision 1.124 2005/04/27 20:09:25 vsc
276 * indexing code could get confused with suspension points
277 * some further improvements on oveflow handling
278 * fix paths in Java makefile
279 * changs to support gibbs sampling in CLP(BN)
280 *
281 * Revision 1.123 2005/04/21 13:53:05 vsc
282 * fix bug with (var(X) -> being interpreted as var(X) by indexing code
283 *
284 * Revision 1.122 2005/04/10 04:01:12 vsc
285 * bug fixes, I hope!
286 *
287 * Revision 1.121 2005/04/07 17:48:54 ricroc
288 * Adding tabling support for mixed strategy evaluation (batched and local scheduling)
289 * UPDATE: compilation flags -DTABLING_BATCHED_SCHEDULING and -DTABLING_LOCAL_SCHEDULING removed. To support tabling use -DTABLING in the Makefile or --enable-tabling in configure.
290 * NEW: yap_flag(tabling_mode,MODE) changes the tabling execution mode of all tabled predicates to MODE (batched, local or default).
291 * NEW: tabling_mode(PRED,MODE) changes the default tabling execution mode of predicate PRED to MODE (batched or local).
292 *
293 * Revision 1.120 2005/03/15 18:29:23 vsc
294 * fix GPL
295 * fix idb: stuff in coroutines.
296 *
297 * Revision 1.119 2005/03/04 20:30:12 ricroc
298 * bug fixes for YapTab support
299 *
300 * Revision 1.118 2005/03/01 22:25:08 vsc
301 * fix pruning bug
302 * make DL_MALLOC less enthusiastic about walking through buckets.
303 *
304 * Revision 1.117 2005/02/25 00:09:06 vsc
305 * fix fix, otherwise I'd remove two choice-points :-(.
306 *
307 * Revision 1.116 2005/02/24 21:46:39 vsc
308 * Improve error handling routine, trying to make it more robust.
309 * Improve hole handling in stack expansion
310 * Clause interrpeter was supposed to prune _trust_me
311 * Wrong messages for acos and atanh
312 *
313 * Revision 1.115 2005/02/21 16:50:00 vsc
314 * amd64 fixes
315 * library fixes
316 *
317 * Revision 1.114 2005/01/28 23:14:36 vsc
318 * move to Yap-4.5.7
319 * Fix clause size
320 *
321 * Revision 1.113 2005/01/15 05:21:36 vsc
322 * fix bug in clause emulator
323 *
324 * Revision 1.112 2004/12/28 22:20:35 vsc
325 * some extra bug fixes for trail overflows: some cannot be recovered that easily,
326 * some can.
327 *
328 * Revision 1.111 2004/12/21 17:17:15 vsc
329 * miscounting of variable-only clauses in groups might lead to bug in indexing
330 * code.
331 *
332 * Revision 1.110 2004/12/06 04:50:22 vsc
333 * fix bug in removing first clause of a try sequence (lu preds)
334 *
335 * Revision 1.109 2004/12/05 05:01:24 vsc
336 * try to reduce overheads when running with goal expansion enabled.
337 * CLPBN fixes
338 * Handle overflows when allocating big clauses properly.
339 *
340 * Revision 1.108 2004/11/19 22:08:42 vsc
341 * replace SYSTEM_ERROR by out OUT_OF_WHATEVER_ERROR whenever appropriate.
342 *
343 * Revision 1.107 2004/11/19 17:14:14 vsc
344 * a few fixes for 64 bit compiling.
345 *
346 * Revision 1.106 2004/11/18 22:32:36 vsc
347 * fix situation where we might assume nonextsing double initialisation of C predicates (use
348 * Hidden Pred Flag).
349 * $host_type was double initialised.
350 *
351 * Revision 1.105 2004/11/04 18:22:32 vsc
352 * don't ever use memory that has been freed (that was done by LU).
353 * generic fixes for WIN32 libraries
354 *
355 * Revision 1.104 2004/10/27 15:56:33 vsc
356 * bug fixes on memory overflows and on clauses :- fail being ignored by clause.
357 *
358 * Revision 1.103 2004/10/22 16:53:19 vsc
359 * bug fixes
360 *
361 * Revision 1.102 2004/10/04 18:56:19 vsc
362 * fixes for thread support
363 * fix indexing bug (serious)
364 *
365 * Revision 1.101 2004/09/30 21:37:41 vsc
366 * fixes for thread support
367 *
368 * Revision 1.100 2004/09/30 19:51:54 vsc
369 * fix overflow from within clause/2
370 *
371 * Revision 1.99 2004/09/27 20:45:03 vsc
372 * Mega clauses
373 * Fixes to sizeof(expand_clauses) which was being overestimated
374 * Fixes to profiling+indexing
375 * Fixes to reallocation of memory after restoring
376 * Make sure all clauses, even for C, end in _Ystop
377 * Don't reuse space for Streams
378 * Fix Stream_F on StreaNo+1
379 *
380 * Revision 1.98 2004/09/14 03:30:06 vsc
381 * make sure that condor version always grows trail!
382 *
383 * Revision 1.97 2004/09/03 03:11:09 vsc
384 * memory management fixes
385 *
386 * Revision 1.96 2004/08/27 20:18:52 vsc
387 * more small fixes
388 *
389 * Revision 1.95 2004/08/11 16:14:52 vsc
390 * whole lot of fixes:
391 * - memory leak in indexing
392 * - memory management in WIN32 now supports holes
393 * - extend Yap interface, more support for SWI-Interface
394 * - new predicate mktime in system
395 * - buffer console I/O in WIN32
396 *
397 * Revision 1.94 2004/07/29 18:15:18 vsc
398 * fix severe bug in indexing of floating point numbers
399 *
400 * Revision 1.93 2004/07/23 19:01:14 vsc
401 * fix bad ref count in expand_clauses when copying indexing block
402 *
403 * Revision 1.92 2004/06/29 19:04:42 vsc
404 * fix multithreaded version
405 * include new version of Ricardo's profiler
406 * new predicat atomic_concat
407 * allow multithreaded-debugging
408 * small fixes
409 *
410 * Revision 1.91 2004/06/17 22:07:23 vsc
411 * bad bug in indexing code.
412 *
413 * Revision 1.90 2004/04/29 03:44:04 vsc
414 * fix bad suspended clause counter
415 *
416 * Revision 1.89 2004/04/27 15:03:43 vsc
417 * more fixes for expand_clauses
418 *
419 * Revision 1.88 2004/04/22 03:24:17 vsc
420 * trust_logical should protect the last clause, otherwise it cannot
421 * jump there.
422 *
423 * Revision 1.87 2004/04/21 04:01:53 vsc
424 * fix bad ordering when inserting second clause
425 *
426 * Revision 1.86 2004/04/20 22:08:23 vsc
427 * fixes for corourining
428 *
429 * Revision 1.85 2004/04/16 19:27:31 vsc
430 * more bug fixes
431 *
432 * Revision 1.84 2004/04/14 19:10:38 vsc
433 * expand_clauses: keep a list of clauses to expand
434 * fix new trail scheme for multi-assignment variables
435 *
436 * Revision 1.83 2004/04/07 22:04:04 vsc
437 * fix memory leaks
438 *
439 * Revision 1.82 2004/03/31 01:02:18 vsc
440 * if number of left-over < 1/5 keep list of clauses to expand around
441 * fix call to stack expander
442 *
443 * Revision 1.81 2004/03/25 02:19:10 pmoura
444 * Removed debugging line to allow compilation.
445 *
446 * Revision 1.80 2004/03/19 11:35:42 vsc
447 * trim_trail for default machine
448 * be more aggressive about try-retry-trust chains.
449 * - handle cases where block starts with a wait
450 * - don't use _killed instructions, just let the thing rot by itself.
451 * *
452 * *
453 *************************************************************************/
454 #ifdef SCCS
455 static char SccsId[] = "%W% %G%";
456 #endif
457
458 /*
459 * This file compiles and removes the indexation code for the prolog compiler
460 *
461 * Some remarks: *try_me always point to inside the code;
462 * try always points to outside
463 *
464
465 Algorithm:
466
467 - fetch info on all clauses
468 - if #clauses =1 return
469 - compute groups:
470 seq of variable only clauses
471 seq: of one or more type instructions
472 bound clauses
473 - sort group
474 - select constant
475 --> type instructions
476 --> count constants
477 --> switch
478 for all arguments:
479 select new argument
480
481 */
482
483 #include "absmi.h"
484 #include "compile.h"
485 #include "index.h"
486 #ifdef DEBUG
487 #include "yapio.h"
488 #endif
489 #ifndef NULL
490 #define NULL (void *)0
491 #endif
492 #if HAVE_STRING_H
493 #include <string.h>
494 #endif
495 #ifdef CUT_C
496 #include "cut_c.h"
497 #endif
498
499 UInt STATIC_PROTO(do_index, (ClauseDef *,ClauseDef *,struct intermediates *,UInt,UInt,int,int,CELL *));
500 UInt STATIC_PROTO(do_compound_index, (ClauseDef *,ClauseDef *,Term *t,struct intermediates *,UInt,UInt,UInt,UInt,int,int,int,CELL *,int));
501 UInt STATIC_PROTO(do_dbref_index, (ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *));
502 UInt STATIC_PROTO(do_blob_index, (ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *,int));
503
504 static UInt
cleanup_sw_on_clauses(CELL larg,UInt sz,OPCODE ecls)505 cleanup_sw_on_clauses(CELL larg, UInt sz, OPCODE ecls)
506 {
507 if (larg & 1) {
508 return sz;
509 } else {
510 yamop *xp = (yamop *)larg;
511 if (xp->opc == ecls) {
512 if (xp->u.sssllp.s3 == 1) {
513 UInt nsz = sz + (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *);
514 LOCK(ExpandClausesListLock);
515 if (ExpandClausesFirst == xp)
516 ExpandClausesFirst = xp->u.sssllp.snext;
517 if (ExpandClausesLast == xp) {
518 ExpandClausesLast = xp->u.sssllp.sprev;
519 }
520 if (xp->u.sssllp.sprev) {
521 xp->u.sssllp.sprev->u.sssllp.snext = xp->u.sssllp.snext;
522 }
523 if (xp->u.sssllp.snext) {
524 xp->u.sssllp.snext->u.sssllp.sprev = xp->u.sssllp.sprev;
525 }
526 UNLOCK(ExpandClausesListLock);
527 #if DEBUG
528 Yap_ExpandClauses--;
529 Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *);
530 #endif
531 if (xp->u.sssllp.p->PredFlags & LogUpdatePredFlag) {
532 Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+xp->u.sssllp.s1*sizeof(yamop *);
533 } else
534 Yap_IndexSpace_EXT -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+xp->u.sssllp.s1*sizeof(yamop *);
535 Yap_FreeCodeSpace((char *)xp);
536 return nsz;
537 } else {
538 xp->u.sssllp.s3--;
539 return sz;
540 }
541 } else {
542 return sz;
543 }
544 }
545 }
546
547 static UInt
recover_from_failed_susp_on_cls(struct intermediates * cint,UInt sz)548 recover_from_failed_susp_on_cls(struct intermediates *cint, UInt sz)
549 {
550 /* we have to recover all allocated blocks,
551 just follow the code through. */
552 struct PSEUDO *cpc = cint->CodeStart;
553 OPCODE ecls = Yap_opcode(_expand_clauses);
554 UInt log_upd_pred = cint->CurrentPred->PredFlags & LogUpdatePredFlag;
555
556 while (cpc) {
557 switch(cpc->op) {
558 case enter_lu_op:
559 if (cpc->rnd4) {
560 yamop *code_p = (yamop *)cpc->rnd4;
561 yamop *first = code_p->u.Ills.l1;
562 yamop *last = code_p->u.Ills.l2;
563 while (first) {
564 yamop *next = first->u.OtaLl.n;
565 LogUpdClause *cl = first->u.OtaLl.d;
566 cl->ClRefCount--;
567 Yap_FreeCodeSpace((char *)first);
568 if (first == last)
569 break;
570 first = next;
571 }
572 }
573 cpc->rnd4 = Zero;
574 break;
575 case jump_v_op:
576 case jump_nv_op:
577 sz = cleanup_sw_on_clauses(cpc->rnd1, sz, ecls);
578 break;
579 case switch_on_type_op:
580 {
581 TypeSwitch *type_sw = (TypeSwitch *)(cpc->arnds);
582 sz = cleanup_sw_on_clauses(type_sw->PairEntry, sz, ecls);
583 sz = cleanup_sw_on_clauses(type_sw->ConstEntry, sz, ecls);
584 sz = cleanup_sw_on_clauses(type_sw->FuncEntry, sz, ecls);
585 sz = cleanup_sw_on_clauses(type_sw->VarEntry, sz, ecls);
586 }
587 break;
588 case switch_c_op:
589 case if_c_op:
590 {
591 AtomSwiEntry *target = (AtomSwiEntry *)(cpc->rnd2);
592 int cases = cpc->rnd1, i;
593
594 for (i = 0; i < cases; i++) {
595 sz = cleanup_sw_on_clauses(target[i].u.Label, sz, ecls);
596 }
597 if (log_upd_pred) {
598 LogUpdIndex *lcl = ClauseCodeToLogUpdIndex(cpc->rnd2);
599 sz += sizeof(LogUpdIndex)+cases*sizeof(AtomSwiEntry);
600 Yap_LUIndexSpace_SW -= sizeof(LogUpdIndex)+cases*sizeof(AtomSwiEntry);
601 Yap_FreeCodeSpace((char *)lcl);
602 } else {
603 StaticIndex *scl = ClauseCodeToStaticIndex(cpc->rnd2);
604 sz += sizeof(StaticIndex)+cases*sizeof(AtomSwiEntry);
605 Yap_IndexSpace_SW -= sizeof(StaticIndex)+cases*sizeof(AtomSwiEntry);
606 Yap_FreeCodeSpace((char *)scl);
607 }
608 }
609 break;
610 case switch_f_op:
611 case if_f_op:
612 {
613 FuncSwiEntry *target = (FuncSwiEntry *)(cpc->rnd2);
614 int cases = cpc->rnd1, i;
615
616 for (i = 0; i < cases; i++) {
617 sz = cleanup_sw_on_clauses(target[i].u.Label, sz, ecls);
618 }
619 if (log_upd_pred) {
620 LogUpdIndex *lcl = ClauseCodeToLogUpdIndex(cpc->rnd2);
621 sz += sizeof(LogUpdIndex)+cases*sizeof(FuncSwiEntry);
622 Yap_LUIndexSpace_SW -= sizeof(LogUpdIndex)+cases*sizeof(FuncSwiEntry);
623 Yap_FreeCodeSpace((char *)lcl);
624 } else {
625 StaticIndex *scl = ClauseCodeToStaticIndex(cpc->rnd2);
626 Yap_IndexSpace_SW -= sizeof(StaticIndex)+cases*sizeof(FuncSwiEntry);
627 sz += sizeof(StaticIndex)+cases*sizeof(FuncSwiEntry);
628 Yap_FreeCodeSpace((char *)scl);
629 }
630 }
631 break;
632 default:
633 break;
634 }
635 cpc = cpc->nextInst;
636 }
637 Yap_ReleaseCMem(cint);
638 if (cint->code_addr) {
639 Yap_FreeCodeSpace((char *)cint->code_addr);
640 cint->code_addr = NULL;
641 }
642 return sz;
643 }
644
645
646 static inline int
smaller(Term t1,Term t2)647 smaller(Term t1, Term t2)
648 {
649 CELL tg1 = LowTagOf(t1), tg2 = LowTagOf(t2);
650 if (tg1 == tg2) {
651 return t1 < t2;
652 } else
653 return tg1 < tg2;
654 }
655
656 static inline int
smaller_or_eq(Term t1,Term t2)657 smaller_or_eq(Term t1, Term t2)
658 {
659 CELL tg1 = LowTagOf(t1), tg2 = LowTagOf(t2);
660 if (tg1 == tg2) {
661 return t1 <= t2;
662 } else
663 return tg1 < tg2;
664 }
665
666 static inline void
clcpy(ClauseDef * d,ClauseDef * s)667 clcpy(ClauseDef *d, ClauseDef *s)
668 {
669 memcpy((void *)d, (void *)s, sizeof(ClauseDef));
670 }
671
672 static void
insort(ClauseDef base[],CELL * p,CELL * q,int my_p)673 insort(ClauseDef base[], CELL *p, CELL *q, int my_p)
674 {
675 CELL *j;
676
677 if (my_p) {
678 p[1] = p[0];
679 for (j = p; j < q; j += 2) {
680 Term key;
681 Int off = *j;
682 CELL *i;
683
684 key = base[off].Tag;
685 i = j+1;
686
687 /* we are at offset 1 */
688 while (i > p+1 && smaller(key,base[i[-2]].Tag)) {
689 i[0] = i[-2];
690 i -= 2;
691 }
692 i[0] = off;
693 }
694 } else {
695 for (j = p+2; j < q; j += 2) {
696 Term key;
697 Int off = *j;
698 CELL *i;
699
700 key = base[off].Tag;
701 i = j;
702
703 /* we are at offset 1 */
704 while (i > p && smaller(key,base[i[-2]].Tag)) {
705 i[0] = i[-2];
706 i -= 2;
707 }
708 i[0] = off;
709 }
710 }
711 }
712
713
714 /* copy to a new list of terms */
715 static
msort(ClauseDef * base,CELL * pt,Int size,int my_p)716 void msort(ClauseDef *base, CELL *pt, Int size, int my_p)
717 {
718
719 if (size > 2) {
720 Int half_size = size / 2;
721 CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
722 int left_p, right_p;
723
724 if (size < 50) {
725 insort(base, pt, pt+2*size, my_p);
726 return;
727 }
728 pt_right = pt + half_size*2;
729 left_p = my_p^1;
730 right_p = my_p;
731 msort(base, pt, half_size, left_p);
732 msort(base, pt_right, size-half_size, right_p);
733 /* now implement a simple merge routine */
734
735 /* pointer to after the end of the list */
736 end_pt = pt + 2*size;
737 /* pointer to the element after the last element to the left */
738 end_pt_left = pt+half_size*2;
739 /* where is left list */
740 pt_left = pt+left_p;
741 /* where is right list */
742 pt_right += right_p;
743 /* where is new list */
744 pt += my_p;
745 /* while there are elements in the left or right vector do compares */
746 while (pt_left < end_pt_left && pt_right < end_pt) {
747 /* if the element to the left is larger than the one to the right */
748 if (smaller_or_eq(base[pt_left[0]].Tag, base[pt_right[0]].Tag)) {
749 /* copy the one to the left */
750 pt[0] = pt_left[0];
751 /* and avance the two pointers */
752 pt += 2;
753 pt_left += 2;
754 } else {
755 /* otherwise, copy the one to the right */
756 pt[0] = pt_right[0];
757 pt += 2;
758 pt_right += 2;
759 }
760 }
761 /* if any elements were left in the left vector just copy them */
762 while (pt_left < end_pt_left) {
763 pt[0] = pt_left[0];
764 pt += 2;
765 pt_left += 2;
766 }
767 /* if any elements were left in the right vector
768 and they are in the wrong place, just copy them */
769 if (my_p != right_p) {
770 while(pt_right < end_pt) {
771 pt[0] = pt_right[0];
772 pt += 2;
773 pt_right += 2;
774 }
775 }
776 } else {
777 if (size > 1 && smaller(base[pt[2]].Tag,base[pt[0]].Tag)) {
778 CELL t = pt[2];
779 pt[2+my_p] = pt[0];
780 pt[my_p] = t;
781 } else if (my_p) {
782 pt[1] = pt[0];
783 if (size > 1)
784 pt[3] = pt[2];
785 }
786 }
787 }
788
789 static void
copy_back(ClauseDef * dest,CELL * pt,int max)790 copy_back(ClauseDef *dest, CELL *pt, int max) {
791 /* first need to say that we had no need to make a copy */
792 int i;
793 CELL *tmp = pt;
794 for (i=0; i < max; i++) {
795 if (*tmp != i) {
796 ClauseDef cl;
797 int j = i;
798 CELL *pnt = tmp;
799
800 /* found a chain */
801 /* make a backup copy */
802 clcpy(&cl, dest+i);
803 do {
804 /* follow the chain */
805 int k = *pnt;
806
807 *pnt = j;
808 /* printf("i=%d, k = %d, j = %d\n",i,j,k); */
809 if (k == i) {
810 clcpy(dest+j, &cl);
811 break;
812 } else {
813 clcpy(dest+j, dest+k);
814 }
815 pnt = pt+2*k;
816 j = k;
817 } while (TRUE);
818 }
819 /* we don't need to do swap */
820 tmp += 2;
821 }
822 }
823
824 /* sort a group of clauses by using their tags */
825 static void
sort_group(GroupDef * grp,CELL * top,struct intermediates * cint)826 sort_group(GroupDef *grp, CELL *top, struct intermediates *cint)
827 {
828 int max = (grp->LastClause-grp->FirstClause)+1, i;
829 CELL *pt, *base;
830
831 #if USE_SYSTEM_MALLOC
832 if (!(base = (CELL *)Yap_AllocCodeSpace(2*max*sizeof(CELL)))) {
833 save_machine_regs();
834 Yap_Error_Size = 2*max*sizeof(CELL);
835 siglongjmp(cint->CompilerBotch,2);
836 }
837 #else
838 base = top;
839 while (top+2*max > (CELL *)Yap_TrailTop) {
840 if (!Yap_growtrail(2*max*CellSize, TRUE)) {
841 save_machine_regs();
842 siglongjmp(cint->CompilerBotch,4);
843 return;
844 }
845 }
846 #endif
847 pt = base;
848 /* initialise vector */
849 for (i=0; i < max; i++) {
850 *pt = i;
851 pt += 2;
852 }
853 #define M_EVEN 0
854 msort(grp->FirstClause, base, max, M_EVEN);
855 copy_back(grp->FirstClause, base, max);
856 #if USE_SYSTEM_MALLOC
857 Yap_FreeCodeSpace((ADDR)base);
858 #endif
859 }
860
861 /* add copy to register stack for original reg */
862 static int
init_regcopy(wamreg regs[MAX_REG_COPIES],wamreg copy)863 init_regcopy(wamreg regs[MAX_REG_COPIES], wamreg copy)
864 {
865 regs[0] = copy;
866 return 1;
867 }
868
869 /* add copy to register stack for original reg */
870 static int
is_regcopy(wamreg regs[MAX_REG_COPIES],int regs_count,wamreg copy)871 is_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
872 {
873 int i = 0;
874 while (i < regs_count) {
875 if (regs[i] == copy) {
876 return TRUE;
877 }
878 i++;
879 }
880 /* this copy had overflowed, or it just was not there */
881 return FALSE;
882 }
883
884 /* add copy to register stack for original reg */
885 static int
delete_regcopy(wamreg regs[MAX_REG_COPIES],int regs_count,wamreg copy)886 delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
887 {
888 int i = 0;
889 while (i < regs_count) {
890 if (regs[i] == copy) {
891 /* we found it */
892 regs[i] = regs[regs_count-1];
893 return regs_count-1;
894 }
895 i++;
896 }
897 /* this copy had overflowed, or it just was not there */
898 return regs_count;
899 }
900
901 /* add copy to register stack for original reg */
902 static int
add_regcopy(wamreg regs[MAX_REG_COPIES],int regs_count,Int source,Int copy)903 add_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, Int source, Int copy)
904 {
905 int i = 0;
906 while (i < regs_count) {
907 if (regs[i] == source) {
908 /* we found it, add new element as last element */
909 if (regs_count == MAX_REG_COPIES) {
910 return regs_count;
911 }
912 regs[regs_count] = copy;
913 return regs_count+1;
914 }
915 i++;
916 }
917 /* be careful: we may overwrite an existing copy */
918 return delete_regcopy(regs, regs_count, copy);
919 }
920
921
922
923 /* add copy to register stack for original reg */
924 inline static int
link_regcopies(wamreg regs[MAX_REG_COPIES],int regs_count,Int c1,Int c2)925 link_regcopies(wamreg regs[MAX_REG_COPIES], int regs_count, Int c1, Int c2)
926 {
927 int i;
928 for (i=0; i<regs_count; i++) {
929 if (regs[i] == c1) {
930 return add_regcopy(regs, regs_count, c1, c2);
931 }
932 if (regs[i] == c2) {
933 return add_regcopy(regs, regs_count, c2, c1);
934 }
935 }
936 /* this copy could not be found */
937 regs_count = delete_regcopy(regs, regs_count, c1);
938 return delete_regcopy(regs, regs_count, c2);
939 }
940
941 /* Restores a prolog clause, in its compiled form */
942 #if YAPOR
943 static int
has_cut(yamop * pc)944 has_cut(yamop *pc)
945 /*
946 * Cl points to the start of the code, IsolFlag tells if we have a single
947 * clause for this predicate or not
948 */
949 {
950 do {
951 op_numbers op = Yap_op_from_opcode(pc->opc);
952 switch (op) {
953 case _unify_idb_term:
954 case _copy_idb_term:
955 case _Ystop:
956 case _Nstop:
957 return FALSE;
958 /* instructions type ld */
959 case _cut:
960 case _cut_t:
961 case _cut_e:
962 case _p_cut_by_y:
963 case _p_cut_by_x:
964 case _commit_b_y:
965 case _commit_b_x:
966 #if CUT_C
967 case _cut_c:
968 case _cut_userc:
969 #endif
970 return TRUE;
971 case _try_me:
972 case _retry_me:
973 case _trust_me:
974 case _profiled_retry_me:
975 case _profiled_trust_me:
976 case _count_retry_me:
977 case _count_trust_me:
978 case _spy_or_trymark:
979 case _try_and_mark:
980 case _profiled_retry_and_mark:
981 case _count_retry_and_mark:
982 case _retry_and_mark:
983 case _try_clause:
984 case _retry:
985 case _trust:
986 #ifdef YAPOR
987 case _getwork:
988 case _getwork_seq:
989 case _sync:
990 #endif /* YAPOR */
991 #ifdef TABLING
992 case _table_load_answer:
993 case _table_try_answer:
994 case _table_try_single:
995 case _table_try_me:
996 case _table_retry_me:
997 case _table_trust_me:
998 case _table_try:
999 case _table_retry:
1000 case _table_trust:
1001 case _table_answer_resolution:
1002 case _table_completion:
1003 #endif /* TABLING */
1004 pc = NEXTOP(pc,Otapl);
1005 break;
1006 /* instructions type Ills */
1007 case _enter_lu_pred:
1008 pc = pc->u.Ills.l1;
1009 break;
1010 case _execute:
1011 case _dexecute:
1012 case _execute_cpred:
1013 pc = NEXTOP(pc,pp);
1014 break;
1015 case _native_me:
1016 pc = NEXTOP(pc,aFlp);
1017 break;
1018 /* instructions type Osbpi */
1019 case _ensure_space:
1020 pc = NEXTOP(pc,Osbpi);
1021 break;
1022 /* instructions type l */
1023 case _enter_profiling:
1024 case _count_call:
1025 case _retry_profiled:
1026 case _count_retry:
1027 case _jump:
1028 case _move_back:
1029 case _skip:
1030 case _jump_if_var:
1031 case _try_in:
1032 case _try_clause2:
1033 case _try_clause3:
1034 case _try_clause4:
1035 case _retry2:
1036 case _retry3:
1037 case _retry4:
1038 case _p_eq:
1039 case _p_dif:
1040 pc = NEXTOP(pc,l);
1041 break;
1042 case _jump_if_nonvar:
1043 pc = NEXTOP(pc,xll);
1044 break;
1045 /* instructions type EC */
1046 case _alloc_for_logical_pred:
1047 pc = NEXTOP(pc,L);
1048 break;
1049 /* instructions type e */
1050 case _lock_lu:
1051 case _unlock_lu:
1052 case _trust_fail:
1053 case _op_fail:
1054 case _allocate:
1055 case _write_void:
1056 case _write_list:
1057 case _write_l_list:
1058 #if !defined(YAPOR)
1059 case _or_last:
1060 #endif /* !YAPOR */
1061 case _pop:
1062 case _index_pred:
1063 case _lock_pred:
1064 #if THREADS
1065 case _thread_local:
1066 #endif
1067 case _expand_index:
1068 case _undef_p:
1069 case _spy_pred:
1070 case _p_equal:
1071 case _p_functor:
1072 case _p_execute_tail:
1073 case _index_dbref:
1074 case _index_blob:
1075 case _index_long:
1076 #ifdef YAPOR
1077 case _getwork_first_time:
1078 #endif /* YAPOR */
1079 #ifdef TABLING
1080 case _trie_do_var:
1081 case _trie_trust_var:
1082 case _trie_try_var:
1083 case _trie_retry_var:
1084 case _trie_do_var_in_pair:
1085 case _trie_trust_var_in_pair:
1086 case _trie_try_var_in_pair:
1087 case _trie_retry_var_in_pair:
1088 case _trie_do_val:
1089 case _trie_trust_val:
1090 case _trie_try_val:
1091 case _trie_retry_val:
1092 case _trie_do_val_in_pair:
1093 case _trie_trust_val_in_pair:
1094 case _trie_try_val_in_pair:
1095 case _trie_retry_val_in_pair:
1096 case _trie_do_atom:
1097 case _trie_trust_atom:
1098 case _trie_try_atom:
1099 case _trie_retry_atom:
1100 case _trie_do_atom_in_pair:
1101 case _trie_trust_atom_in_pair:
1102 case _trie_try_atom_in_pair:
1103 case _trie_retry_atom_in_pair:
1104 case _trie_do_null:
1105 case _trie_trust_null:
1106 case _trie_try_null:
1107 case _trie_retry_null:
1108 case _trie_do_null_in_pair:
1109 case _trie_trust_null_in_pair:
1110 case _trie_try_null_in_pair:
1111 case _trie_retry_null_in_pair:
1112 case _trie_do_pair:
1113 case _trie_trust_pair:
1114 case _trie_try_pair:
1115 case _trie_retry_pair:
1116 case _trie_do_appl:
1117 case _trie_trust_appl:
1118 case _trie_try_appl:
1119 case _trie_retry_appl:
1120 case _trie_do_appl_in_pair:
1121 case _trie_trust_appl_in_pair:
1122 case _trie_try_appl_in_pair:
1123 case _trie_retry_appl_in_pair:
1124 case _trie_do_extension:
1125 case _trie_trust_extension:
1126 case _trie_try_extension:
1127 case _trie_retry_extension:
1128 case _trie_do_double:
1129 case _trie_trust_double:
1130 case _trie_try_double:
1131 case _trie_retry_double:
1132 case _trie_do_longint:
1133 case _trie_trust_longint:
1134 case _trie_try_longint:
1135 case _trie_retry_longint:
1136 case _trie_do_gterm:
1137 case _trie_trust_gterm:
1138 case _trie_try_gterm:
1139 case _trie_retry_gterm:
1140 #endif /* TABLING */
1141 pc = NEXTOP(pc,e);
1142 break;
1143 case _expand_clauses:
1144 pc = NEXTOP(pc,sssllp);
1145 break;
1146 /* instructions type x */
1147 case _save_b_x:
1148 case _get_list:
1149 case _put_list:
1150 case _write_x_var:
1151 case _write_x_val:
1152 case _write_x_loc:
1153 pc = NEXTOP(pc,x);
1154 break;
1155 /* instructions type xl */
1156 case _p_atom_x:
1157 case _p_atomic_x:
1158 case _p_integer_x:
1159 case _p_nonvar_x:
1160 case _p_number_x:
1161 case _p_var_x:
1162 case _p_db_ref_x:
1163 case _p_primitive_x:
1164 case _p_compound_x:
1165 case _p_float_x:
1166 pc = NEXTOP(pc,xl);
1167 break;
1168 /* instructions type y */
1169 case _save_b_y:
1170 case _write_y_var:
1171 case _write_y_val:
1172 case _write_y_loc:
1173 pc = NEXTOP(pc,y);
1174 break;
1175 /* instructions type yl */
1176 case _p_atom_y:
1177 case _p_atomic_y:
1178 case _p_integer_y:
1179 case _p_nonvar_y:
1180 case _p_number_y:
1181 case _p_var_y:
1182 case _p_db_ref_y:
1183 case _p_primitive_y:
1184 case _p_compound_y:
1185 case _p_float_y:
1186 pc = NEXTOP(pc,yl);
1187 break;
1188 /* instructions type sbpp */
1189 case _p_execute:
1190 pc = NEXTOP(pc,Osbmp);
1191 break;
1192 case _p_execute2:
1193 case _fcall:
1194 case _call:
1195 case _call_cpred:
1196 case _call_usercpred:
1197 pc = NEXTOP(pc,Osbpp);
1198 break;
1199 /* instructions type sblp */
1200 #ifdef YAPOR
1201 case _or_last:
1202 #endif /* YAPOR */
1203 case _either:
1204 case _or_else:
1205 pc = NEXTOP(pc,Osblp);
1206 break;
1207 /* instructions type xx */
1208 case _get_x_var:
1209 case _get_x_val:
1210 case _glist_valx:
1211 case _gl_void_varx:
1212 case _gl_void_valx:
1213 case _put_x_var:
1214 case _put_x_val:
1215 pc = NEXTOP(pc,xx);
1216 break;
1217 case _put_xx_val:
1218 pc = NEXTOP(pc,xxxx);
1219 break;
1220 /* instructions type yx */
1221 case _get_y_var:
1222 case _get_y_val:
1223 case _put_y_var:
1224 case _put_y_val:
1225 case _put_unsafe:
1226 case _glist_valy:
1227 case _gl_void_vary:
1228 case _gl_void_valy:
1229 pc = NEXTOP(pc,yx);
1230 break;
1231 /* instructions type xd */
1232 case _get_float:
1233 case _put_float:
1234 pc = NEXTOP(pc,xd);
1235 break;
1236 /* instructions type xi */
1237 case _get_longint:
1238 case _put_longint:
1239 pc = NEXTOP(pc,xi);
1240 break;
1241 /* instructions type xc */
1242 case _get_atom:
1243 case _put_atom:
1244 case _get_bigint:
1245 case _get_dbterm:
1246 pc = NEXTOP(pc,xc);
1247 break;
1248 /* instructions type cc */
1249 case _get_2atoms:
1250 pc = NEXTOP(pc,cc);
1251 break;
1252 /* instructions type ccc */
1253 case _get_3atoms:
1254 pc = NEXTOP(pc,ccc);
1255 break;
1256 /* instructions type cccc */
1257 case _get_4atoms:
1258 pc = NEXTOP(pc,cccc);
1259 break;
1260 /* instructions type ccccc */
1261 case _get_5atoms:
1262 pc = NEXTOP(pc,ccccc);
1263 break;
1264 /* instructions type cccccc */
1265 case _get_6atoms:
1266 pc = NEXTOP(pc,cccccc);
1267 break;
1268 /* instructions type xfa */
1269 case _get_struct:
1270 case _put_struct:
1271 pc = NEXTOP(pc,xfa);
1272 break;
1273 /* instructions type yx */
1274 /* instructions type ox */
1275 case _unify_x_var:
1276 case _unify_x_var_write:
1277 case _unify_l_x_var:
1278 case _unify_l_x_var_write:
1279 case _unify_x_val_write:
1280 case _unify_x_val:
1281 case _unify_l_x_val_write:
1282 case _unify_l_x_val:
1283 case _unify_x_loc_write:
1284 case _unify_x_loc:
1285 case _unify_l_x_loc_write:
1286 case _unify_l_x_loc:
1287 case _save_pair_x_write:
1288 case _save_pair_x:
1289 case _save_appl_x_write:
1290 case _save_appl_x:
1291 pc = NEXTOP(pc,ox);
1292 break;
1293 /* instructions type oxx */
1294 case _unify_x_var2:
1295 case _unify_x_var2_write:
1296 case _unify_l_x_var2:
1297 case _unify_l_x_var2_write:
1298 pc = NEXTOP(pc,oxx);
1299 break;
1300 /* instructions type oy */
1301 case _unify_y_var:
1302 case _unify_y_var_write:
1303 case _unify_l_y_var:
1304 case _unify_l_y_var_write:
1305 case _unify_y_val_write:
1306 case _unify_y_val:
1307 case _unify_l_y_val_write:
1308 case _unify_l_y_val:
1309 case _unify_y_loc_write:
1310 case _unify_y_loc:
1311 case _unify_l_y_loc_write:
1312 case _unify_l_y_loc:
1313 case _save_pair_y_write:
1314 case _save_pair_y:
1315 case _save_appl_y_write:
1316 case _save_appl_y:
1317 pc = NEXTOP(pc,oy);
1318 break;
1319 /* instructions type o */
1320 case _unify_void_write:
1321 case _unify_void:
1322 case _unify_l_void_write:
1323 case _unify_l_void:
1324 case _unify_list_write:
1325 case _unify_list:
1326 case _unify_l_list_write:
1327 case _unify_l_list:
1328 pc = NEXTOP(pc,o);
1329 break;
1330 /* instructions type os */
1331 case _unify_n_voids_write:
1332 case _unify_n_voids:
1333 case _unify_l_n_voids_write:
1334 case _unify_l_n_voids:
1335 pc = NEXTOP(pc,os);
1336 break;
1337 /* instructions type od */
1338 case _unify_float:
1339 case _unify_l_float:
1340 case _unify_float_write:
1341 case _unify_l_float_write:
1342 pc = NEXTOP(pc,od);
1343 break;
1344 /* instructions type d */
1345 case _write_float:
1346 pc = NEXTOP(pc,d);
1347 break;
1348 /* instructions type oi */
1349 case _unify_longint:
1350 case _unify_l_longint:
1351 case _unify_longint_write:
1352 case _unify_l_longint_write:
1353 pc = NEXTOP(pc,oi);
1354 break;
1355 /* instructions type i */
1356 case _write_longint:
1357 pc = NEXTOP(pc,i);
1358 break;
1359 /* instructions type oc */
1360 case _unify_atom_write:
1361 case _unify_atom:
1362 case _unify_l_atom_write:
1363 case _unify_l_atom:
1364 case _unify_bigint:
1365 case _unify_l_bigint:
1366 case _unify_dbterm:
1367 case _unify_l_dbterm:
1368 pc = NEXTOP(pc,oc);
1369 break;
1370 /* instructions type osc */
1371 case _unify_n_atoms_write:
1372 case _unify_n_atoms:
1373 pc = NEXTOP(pc,osc);
1374 break;
1375 /* instructions type of */
1376 case _unify_struct_write:
1377 case _unify_struct:
1378 case _unify_l_struc_write:
1379 case _unify_l_struc:
1380 pc = NEXTOP(pc,ofa);
1381 break;
1382 /* instructions type s */
1383 case _write_n_voids:
1384 case _pop_n:
1385 #ifdef TABLING
1386 case _table_new_answer:
1387 #endif /* TABLING */
1388 pc = NEXTOP(pc,s);
1389 break;
1390 /* instructions type ps */
1391 case _write_atom:
1392 pc = NEXTOP(pc,c);
1393 break;
1394 /* instructions type p */
1395 case _user_switch:
1396 return FALSE;
1397 case _deallocate:
1398 case _procceed:
1399 pc = NEXTOP(pc,p);
1400 break;
1401 /* instructions type sc */
1402 case _write_n_atoms:
1403 pc = NEXTOP(pc,sc);
1404 break;
1405 /* instructions type f */
1406 case _write_struct:
1407 case _write_l_struc:
1408 pc = NEXTOP(pc,fa);
1409 break;
1410 /* instructions type slp */
1411 case _call_c_wfail:
1412 pc = NEXTOP(pc,slp);
1413 break;
1414 /* instructions type lds */
1415 case _try_c:
1416 case _try_userc:
1417 pc = NEXTOP(pc,OtapFs);
1418 break;
1419 /* instructions type OtaLl,OtILl */
1420 case _try_logical:
1421 case _retry_logical:
1422 case _count_retry_logical:
1423 case _profiled_retry_logical:
1424 pc = pc->u.OtaLl.n;
1425 break;
1426 case _trust_logical:
1427 case _count_trust_logical:
1428 case _profiled_trust_logical:
1429 pc = pc->u.OtILl.n;
1430 break;
1431 case _retry_c:
1432 case _retry_userc:
1433 pc = NEXTOP(pc,OtapFs);
1434 break;
1435 /* instructions type llll */
1436 case _switch_on_type:
1437 return FALSE;
1438 break;
1439 case _switch_list_nl:
1440 return FALSE;
1441 break;
1442 case _switch_on_arg_type:
1443 return FALSE;
1444 break;
1445 case _switch_on_sub_arg_type:
1446 return FALSE;
1447 /* instructions type lll */
1448 /* instructions type cll */
1449 case _if_not_then:
1450 return FALSE;
1451 /* instructions type sl */
1452 case _switch_on_func:
1453 case _switch_on_cons:
1454 case _go_on_func:
1455 case _go_on_cons:
1456 case _if_func:
1457 case _if_cons:
1458 return FALSE;
1459 /* instructions type xxx */
1460 case _p_plus_vv:
1461 case _p_minus_vv:
1462 case _p_times_vv:
1463 case _p_div_vv:
1464 case _p_and_vv:
1465 case _p_or_vv:
1466 case _p_sll_vv:
1467 case _p_slr_vv:
1468 case _p_arg_vv:
1469 case _p_func2s_vv:
1470 case _p_func2f_xx:
1471 pc = NEXTOP(pc,xxx);
1472 break;
1473 /* instructions type xxn */
1474 case _p_plus_vc:
1475 case _p_minus_cv:
1476 case _p_times_vc:
1477 case _p_div_cv:
1478 case _p_and_vc:
1479 case _p_or_vc:
1480 case _p_sll_vc:
1481 case _p_slr_vc:
1482 case _p_func2s_vc:
1483 pc = NEXTOP(pc,xxn);
1484 break;
1485 case _p_div_vc:
1486 case _p_sll_cv:
1487 case _p_slr_cv:
1488 case _p_arg_cv:
1489 pc = NEXTOP(pc,xxn);
1490 break;
1491 case _p_func2s_cv:
1492 pc = NEXTOP(pc,xxn);
1493 break;
1494 /* instructions type xxy */
1495 case _p_func2f_xy:
1496 pc = NEXTOP(pc,xxy);
1497 break;
1498 /* instructions type yxx */
1499 case _p_plus_y_vv:
1500 case _p_minus_y_vv:
1501 case _p_times_y_vv:
1502 case _p_div_y_vv:
1503 case _p_and_y_vv:
1504 case _p_or_y_vv:
1505 case _p_sll_y_vv:
1506 case _p_slr_y_vv:
1507 case _p_arg_y_vv:
1508 case _p_func2s_y_vv:
1509 case _p_func2f_yx:
1510 pc = NEXTOP(pc,yxx);
1511 break;
1512 /* instructions type yyx */
1513 case _get_yy_var:
1514 case _put_y_vals:
1515 pc = NEXTOP(pc,yyxx);
1516 break;
1517 /* instructions type yyx */
1518 case _p_func2f_yy:
1519 pc = NEXTOP(pc,yyx);
1520 break;
1521 /* instructions type yxn */
1522 case _p_plus_y_vc:
1523 case _p_minus_y_cv:
1524 case _p_times_y_vc:
1525 case _p_div_y_vc:
1526 case _p_div_y_cv:
1527 case _p_and_y_vc:
1528 case _p_or_y_vc:
1529 case _p_sll_y_vc:
1530 case _p_slr_y_vc:
1531 case _p_func2s_y_vc:
1532 pc = NEXTOP(pc,yxn);
1533 break;
1534 /* instructions type yxn */
1535 case _p_sll_y_cv:
1536 case _p_slr_y_cv:
1537 case _p_arg_y_cv:
1538 pc = NEXTOP(pc,yxn);
1539 break;
1540 /* instructions type yxn */
1541 case _p_func2s_y_cv:
1542 pc = NEXTOP(pc,yxn);
1543 break;
1544 /* instructions type plxxs */
1545 case _call_bfunc_xx:
1546 pc = NEXTOP(pc,plxxs);
1547 break;
1548 /* instructions type plxys */
1549 case _call_bfunc_yx:
1550 case _call_bfunc_xy:
1551 pc = NEXTOP(pc,plxys);
1552 break;
1553 case _call_bfunc_yy:
1554 pc = NEXTOP(pc,plyys);
1555 break;
1556 }
1557 } while (TRUE);
1558 }
1559 #else
1560 #define has_cut(pc) 0
1561 #endif /* YAPOR */
1562
1563 static void
add_info(ClauseDef * clause,UInt regno)1564 add_info(ClauseDef *clause, UInt regno)
1565 {
1566 wamreg myregs[MAX_REG_COPIES];
1567 int nofregs;
1568 yamop *cl;
1569
1570 nofregs = init_regcopy(myregs, Yap_regnotoreg(regno));
1571 cl = clause->CurrentCode;
1572 #include "findclause.h"
1573 }
1574
1575 static void
add_head_info(ClauseDef * clause,UInt regno)1576 add_head_info(ClauseDef *clause, UInt regno)
1577 {
1578 wamreg iarg = Yap_regnotoreg(regno);
1579
1580 yamop *cl = clause->CurrentCode;
1581 #include "headclause.h"
1582 }
1583
1584 static void
move_next(ClauseDef * clause,UInt regno)1585 move_next(ClauseDef *clause, UInt regno)
1586 {
1587 yamop *cl = clause->CurrentCode;
1588 wamreg wreg = Yap_regnotoreg(regno);
1589 op_numbers op = Yap_op_from_opcode(cl->opc);
1590
1591 switch (op) {
1592 case _native_me:
1593 return;
1594 case _p_db_ref_x:
1595 case _p_float_x:
1596 if (wreg == cl->u.xl.x) {
1597 clause->CurrentCode = NEXTOP(cl,xl);
1598 }
1599 return;
1600 case _get_list:
1601 if (wreg == cl->u.x.x) {
1602 clause->CurrentCode = NEXTOP(cl,x);
1603 }
1604 return;
1605 case _glist_valx:
1606 case _gl_void_vary:
1607 case _gl_void_valy:
1608 case _gl_void_varx:
1609 case _gl_void_valx:
1610 case _glist_valy:
1611 return;
1612 case _get_atom:
1613 if (wreg == cl->u.xc.x) {
1614 clause->CurrentCode = NEXTOP(cl,xc);
1615 }
1616 return;
1617 case _get_2atoms:
1618 return;
1619 case _get_3atoms:
1620 return;
1621 case _get_4atoms:
1622 return;
1623 case _get_5atoms:
1624 return;
1625 case _get_6atoms:
1626 return;
1627 /*
1628 matching is not guaranteed:
1629 case _get_float:
1630 case _get_longint:
1631 case _get_bigint:
1632 */
1633 case _get_struct:
1634 if (wreg == cl->u.xfa.x) {
1635 clause->CurrentCode = NEXTOP(cl,xfa);
1636 }
1637 default:
1638 clause->CurrentCode = clause->Code;
1639 return;
1640 }
1641 }
1642
1643 static void
add_arg_info(ClauseDef * clause,PredEntry * ap,UInt argno)1644 add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno)
1645 {
1646 yamop *cl;
1647 if (ap->ModuleOfPred == IDB_MODULE) {
1648 cl = clause->Code;
1649 } else {
1650 cl = clause->u.WorkPC;
1651 }
1652 while (TRUE) {
1653 op_numbers op = Yap_op_from_opcode(cl->opc);
1654 switch (op) {
1655 case _glist_valx:
1656 if (argno == 1) {
1657 clause->Tag = (CELL)NULL;
1658 return;
1659 }
1660 argno--;
1661 cl = NEXTOP(cl,xx);
1662 break;
1663 case _gl_void_vary:
1664 case _gl_void_valy:
1665 case _gl_void_varx:
1666 case _gl_void_valx:
1667 clause->Tag = (CELL)NULL;
1668 return;
1669 case _glist_valy:
1670 if (argno == 1) {
1671 clause->Tag = (CELL)NULL;
1672 return;
1673 }
1674 argno = 2;
1675 cl = NEXTOP(cl,yx);
1676 break;
1677 case _unify_l_x_var:
1678 case _unify_l_x_val:
1679 case _unify_l_x_loc:
1680 case _unify_x_var:
1681 case _unify_x_val:
1682 case _unify_x_loc:
1683 if (argno == 1) {
1684 clause->Tag = (CELL)NULL;
1685 return;
1686 }
1687 argno--;
1688 case _unify_l_x_var_write:
1689 case _unify_l_x_val_write:
1690 case _unify_l_x_loc_write:
1691 case _unify_x_var_write:
1692 case _unify_x_val_write:
1693 case _unify_x_loc_write:
1694 cl = NEXTOP(cl,ox);
1695 break;
1696 case _save_pair_x_write:
1697 case _save_pair_x:
1698 case _save_appl_x_write:
1699 case _save_appl_x:
1700 cl = NEXTOP(cl,ox);
1701 break;
1702 case _unify_l_x_var2:
1703 case _unify_x_var2:
1704 if (argno == 1 || argno == 2) {
1705 clause->Tag = (CELL)NULL;
1706 return;
1707 }
1708 argno -= 2;
1709 case _unify_l_x_var2_write:
1710 case _unify_x_var2_write:
1711 cl = NEXTOP(cl,oxx);
1712 break;
1713 case _unify_y_var:
1714 case _unify_y_val:
1715 case _unify_y_loc:
1716 case _unify_l_y_var:
1717 case _unify_l_y_val:
1718 case _unify_l_y_loc:
1719 /* we're just done with the head of a list, but there
1720 is nothing inside.
1721 */
1722 if (argno == 1) {
1723 clause->Tag = (CELL)NULL;
1724 return;
1725 }
1726 argno--;
1727 case _unify_y_var_write:
1728 case _unify_y_val_write:
1729 case _unify_y_loc_write:
1730 case _unify_l_y_var_write:
1731 case _unify_l_y_val_write:
1732 case _unify_l_y_loc_write:
1733 cl = NEXTOP(cl,oy);
1734 break;
1735 case _save_pair_y_write:
1736 case _save_pair_y:
1737 case _save_appl_y_write:
1738 case _save_appl_y:
1739 cl = NEXTOP(cl,oy);
1740 break;
1741 case _unify_l_void:
1742 case _unify_void:
1743 if (argno == 1) {
1744 clause->Tag = (CELL)NULL;
1745 return;
1746 }
1747 argno--;
1748 case _unify_l_void_write:
1749 case _unify_void_write:
1750 cl = NEXTOP(cl,o);
1751 break;
1752 case _unify_list:
1753 case _unify_l_list:
1754 if (argno == 1) {
1755 clause->Tag = AbsPair(NULL);
1756 clause->u.WorkPC = NEXTOP(cl,o);
1757 return;
1758 }
1759 argno += 1; /* 2-1: have two extra arguments to skip */
1760 case _unify_list_write:
1761 case _unify_l_list_write:
1762 cl = NEXTOP(cl,o);
1763 break;
1764 case _unify_n_voids:
1765 case _unify_l_n_voids:
1766 if (argno <= cl->u.os.s) {
1767 clause->Tag = (CELL)NULL;
1768 return;
1769 }
1770 argno -= cl->u.os.s;
1771 case _unify_n_voids_write:
1772 case _unify_l_n_voids_write:
1773 cl = NEXTOP(cl,os);
1774 break;
1775 case _unify_atom:
1776 case _unify_l_atom:
1777 if (argno == 1) {
1778 clause->Tag = cl->u.oc.c;
1779 return;
1780 }
1781 argno--;
1782 case _unify_atom_write:
1783 case _unify_l_atom_write:
1784 cl = NEXTOP(cl,oc);
1785 break;
1786 case _unify_float_write:
1787 case _unify_l_float_write:
1788 cl = NEXTOP(cl,od);
1789 break;
1790 case _unify_float:
1791 case _unify_l_float:
1792 if (argno == 1) {
1793 clause->Tag = AbsAppl((CELL *)FunctorDouble);
1794 clause->u.t_ptr = AbsAppl(cl->u.od.d);
1795 return;
1796 }
1797 cl = NEXTOP(cl,od);
1798 argno--;
1799 break;
1800 case _unify_longint:
1801 case _unify_l_longint:
1802 if (argno == 1) {
1803 clause->Tag = AbsAppl((CELL *)FunctorLongInt);
1804 clause->u.t_ptr = AbsAppl(cl->u.oi.i);
1805 return;
1806 }
1807 argno--;
1808 cl = NEXTOP(cl,oi);
1809 break;
1810 case _unify_bigint:
1811 case _unify_l_bigint:
1812 if (argno == 1) {
1813 clause->Tag = AbsAppl((CELL *)FunctorBigInt);
1814 clause->u.t_ptr = cl->u.oc.c;
1815 return;
1816 }
1817 cl = NEXTOP(cl,oc);
1818 argno--;
1819 break;
1820 case _unify_n_atoms:
1821 if (argno <= cl->u.osc.s) {
1822 clause->Tag = cl->u.osc.c;
1823 return;
1824 }
1825 argno -= cl->u.osc.s;
1826 case _unify_n_atoms_write:
1827 cl = NEXTOP(cl,osc);
1828 break;
1829 case _unify_struct:
1830 case _unify_l_struc:
1831 if (argno == 1) {
1832 clause->Tag = AbsAppl((CELL *)cl->u.ofa.f);
1833 clause->u.WorkPC = NEXTOP(cl,ofa);
1834 return;
1835 }
1836 /* must skip next n arguments */
1837 argno += cl->u.ofa.a-1;
1838 case _unify_l_struc_write:
1839 case _unify_struct_write:
1840 cl = NEXTOP(cl,ofa);
1841 break;
1842 case _pop:
1843 cl = NEXTOP(cl,e);
1844 break;
1845 case _pop_n:
1846 cl = NEXTOP(cl,s);
1847 break;
1848 #ifdef BEAM
1849 case _run_eam:
1850 cl = NEXTOP(cl,os);
1851 break;
1852 #endif
1853 case _get_dbterm:
1854 cl = NEXTOP(cl,xc);
1855 break;
1856 case _unify_dbterm:
1857 case _unify_l_dbterm:
1858 cl = NEXTOP(cl,oc);
1859 break;
1860 case _unify_idb_term:
1861 case _copy_idb_term:
1862 {
1863 Term t = clause->u.c_sreg[argno];
1864
1865 if (IsVarTerm(t)) {
1866 clause->Tag = (CELL)NULL;
1867 } else if (IsApplTerm(t)) {
1868 CELL *pt = RepAppl(t);
1869
1870 clause->Tag = AbsAppl((CELL *)pt[0]);
1871 if (IsExtensionFunctor(FunctorOfTerm(t))) {
1872 clause->u.t_ptr = t;
1873 } else {
1874 clause->u.c_sreg = pt;
1875 }
1876 } else if (IsPairTerm(t)) {
1877 CELL *pt = RepPair(t);
1878
1879 clause->Tag = AbsPair(NULL);
1880 clause->u.c_sreg = pt-1;
1881 } else {
1882 clause->Tag = t;
1883 }
1884 }
1885 return;
1886 default:
1887 return;
1888 }
1889 }
1890 }
1891
1892 static void
skip_to_arg(ClauseDef * clause,PredEntry * ap,UInt argno,int at_point)1893 skip_to_arg(ClauseDef *clause, PredEntry *ap, UInt argno, int at_point)
1894 {
1895 yamop *cl;
1896 int done = FALSE;
1897 if (ap->ModuleOfPred == IDB_MODULE) {
1898 return;
1899 } else {
1900 cl = clause->CurrentCode;
1901 }
1902
1903 if (!at_point) {
1904 clause->CurrentCode = clause->Code;
1905 return;
1906 }
1907
1908 while (!done) {
1909 op_numbers op = Yap_op_from_opcode(cl->opc);
1910 switch (op) {
1911 #ifdef BEAM
1912 case _run_eam:
1913 clause->CurrentCode = clause->Code;
1914 return;
1915 #endif
1916 case _unify_void:
1917 if (argno == 1) {
1918 clause->CurrentCode = clause->Code;
1919 return;
1920 } else {
1921 argno--;
1922 }
1923 case _unify_void_write:
1924 cl = NEXTOP(cl,o);
1925 break;
1926 case _unify_list:
1927 case _unify_l_list:
1928 case _unify_atom:
1929 case _unify_l_atom:
1930 /*
1931 unification is not guaranteed
1932 case _unify_longint:
1933 case _unify_l_longint:
1934 case _unify_bigint:
1935 case _unify_l_bigint:
1936 case _unify_l_float:
1937 */
1938 case _unify_struct:
1939 case _unify_l_struc:
1940 if (cl == clause->u.WorkPC) {
1941 clause->CurrentCode = cl;
1942 } else {
1943 clause->CurrentCode = clause->Code;
1944 }
1945 return;
1946 case _unify_list_write:
1947 case _unify_l_list_write:
1948 cl = NEXTOP(cl,o);
1949 break;
1950 case _unify_n_voids:
1951 case _unify_l_n_voids:
1952 if (argno <= cl->u.os.s) {
1953 clause->CurrentCode = clause->Code;
1954 return;
1955 } else {
1956 argno -= cl->u.os.s;
1957 }
1958 case _unify_n_voids_write:
1959 case _unify_l_n_voids_write:
1960 cl = NEXTOP(cl,os);
1961 break;
1962 case _unify_atom_write:
1963 case _unify_l_atom_write:
1964 cl = NEXTOP(cl,oc);
1965 break;
1966 case _unify_float_write:
1967 case _unify_l_float_write:
1968 cl = NEXTOP(cl,od);
1969 break;
1970 case _unify_l_struc_write:
1971 case _unify_struct_write:
1972 cl = NEXTOP(cl,ofa);
1973 break;
1974 case _pop:
1975 cl = NEXTOP(cl,e);
1976 break;
1977 case _pop_n:
1978 cl = NEXTOP(cl,s);
1979 break;
1980 default:
1981 clause->CurrentCode = clause->Code;
1982 return;
1983 }
1984 }
1985 }
1986
1987
1988 static UInt
groups_in(ClauseDef * min,ClauseDef * max,GroupDef * grp,struct intermediates * cint)1989 groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *cint)
1990 {
1991 UInt groups = 0;
1992
1993 while(min <= max) {
1994 grp->FirstClause = min;
1995 grp->AtomClauses = 0;
1996 grp->PairClauses = 0;
1997 grp->StructClauses = 0;
1998 grp->TestClauses = 0;
1999 if (min->Tag == (_var+1)*sizeof(CELL)) {
2000 min++;
2001 continue;
2002 }
2003 /* only do this for the first clauses in a group */
2004 if (IsVarTerm(min->Tag)) {
2005 ClauseDef *clp = min+1;
2006
2007 grp->VarClauses = 1;
2008 do {
2009 if (clp > max ||
2010 !IsVarTerm(clp->Tag)) {
2011 grp->LastClause = (min = clp)-1;
2012 break;
2013 }
2014 if (clp->Tag != (_var+1)*sizeof(CELL))
2015 grp->VarClauses++;
2016 clp++;
2017 } while (TRUE);
2018 } else {
2019 grp->VarClauses = 0;
2020 do {
2021 restart_loop:
2022 if (IsAtomTerm(min->Tag) || IsIntTerm(min->Tag)) {
2023 grp->AtomClauses++;
2024 } else if (IsPairTerm(min->Tag)) {
2025 grp->PairClauses++;
2026 } else if (IsApplTerm(min->Tag)) {
2027 grp->StructClauses++;
2028 } else {
2029 grp->TestClauses++;
2030 }
2031 min++;
2032 } while (min <= max &&
2033 (!IsVarTerm(min->Tag)));
2034 if (min <= max && min->Tag == (_var+1)*sizeof(CELL)) {
2035 min++;
2036 if (min < max)
2037 goto restart_loop;
2038 }
2039 grp->LastClause = min-1;
2040 }
2041 groups++;
2042 grp++;
2043 while (grp+16 > (GroupDef *)Yap_TrailTop) {
2044 UInt sz = (groups+16)*sizeof(GroupDef);
2045 #if USE_SYSTEM_MALLOC
2046 Yap_Error_Size = sz;
2047 /* grow stack */
2048 save_machine_regs();
2049 siglongjmp(cint->CompilerBotch,4);
2050 #else
2051 if (!Yap_growtrail(sz, TRUE)) {
2052 save_machine_regs();
2053 siglongjmp(cint->CompilerBotch,4);
2054 return 0;
2055 }
2056 #endif
2057 }
2058 }
2059 return groups;
2060 }
2061
2062 static UInt
new_label(struct intermediates * cint)2063 new_label(struct intermediates *cint)
2064 {
2065 UInt lbl = cint->i_labelno;
2066 cint->i_labelno += 2;
2067 return lbl;
2068 }
2069
2070 static void
emit_trust(ClauseDef * cl,struct intermediates * cint,UInt nxtlbl,int clauses)2071 emit_trust(ClauseDef *cl, struct intermediates *cint, UInt nxtlbl, int clauses)
2072 {
2073 PredEntry *ap = cint->CurrentPred;
2074 yamop *clcode = cl->Code;
2075
2076 if (ap->PredFlags & TabledPredFlag)
2077 clcode = NEXTOP(clcode,Otapl);
2078 if (!(ap->PredFlags & LogUpdatePredFlag)) {
2079 /* this should not be generated for logical update predicates!! */
2080 if (ap->PredFlags & ProfiledPredFlag) {
2081 Yap_emit(retry_profiled_op, Unsigned(ap), Zero, cint);
2082 }
2083 if (ap->PredFlags & CountPredFlag) {
2084 Yap_emit(count_retry_op, Unsigned(ap), Zero, cint);
2085 }
2086 }
2087 if (clauses == 0) {
2088 Yap_emit(trust_op, (CELL)clcode, has_cut(cl->CurrentCode) , cint);
2089 } else {
2090 Yap_emit(retry_op, (CELL)clcode, (clauses << 1) | has_cut(cl->CurrentCode) , cint);
2091 Yap_emit(jumpi_op, nxtlbl, Zero, cint);
2092 }
2093 }
2094
2095 static void
emit_retry(ClauseDef * cl,struct intermediates * cint,int clauses)2096 emit_retry(ClauseDef *cl, struct intermediates *cint, int clauses)
2097 {
2098 PredEntry *ap = cint->CurrentPred;
2099 yamop *clcode = cl->Code;
2100
2101 if (ap->PredFlags & TabledPredFlag)
2102 clcode = NEXTOP(clcode,Otapl);
2103 if (!(ap->PredFlags & LogUpdatePredFlag)) {
2104 /* this should not be generated for logical update predicates!! */
2105 if (ap->PredFlags & ProfiledPredFlag) {
2106 Yap_emit(retry_profiled_op, Unsigned(ap), Zero, cint);
2107 }
2108 if (ap->PredFlags & CountPredFlag) {
2109 Yap_emit(count_retry_op, Unsigned(ap), Zero, cint);
2110 }
2111 }
2112 Yap_emit(retry_op, (CELL)clcode, (clauses << 1) | has_cut(cl->CurrentCode), cint);
2113 }
2114
2115 static compiler_vm_op
emit_optry(int var_group,int first,int clauses,int clleft,PredEntry * ap)2116 emit_optry(int var_group, int first, int clauses, int clleft, PredEntry *ap)
2117 {
2118 /* var group */
2119 if (var_group || clauses == 0) {
2120 if (first) {
2121 return try_op;
2122 } else if (clleft+clauses) {
2123 return retry_op;
2124 } else {
2125 return trust_op;
2126 }
2127 } else if (clleft == 0) {
2128 #ifdef TABLING
2129 if (ap->PredFlags & TabledPredFlag && !first) {
2130 /* we never actually get to remove the last choice-point in this case */
2131 return retry_op;
2132 } else
2133 #endif /* TABLING */
2134 {
2135 /* last group */
2136 return try_op;
2137 }
2138 } else {
2139 /* nonvar group */
2140 return try_in_op;
2141 }
2142 }
2143
2144
2145 static void
emit_try(ClauseDef * cl,struct intermediates * cint,int var_group,int first,int clauses,int clleft,UInt nxtlbl)2146 emit_try(ClauseDef *cl, struct intermediates *cint, int var_group, int first, int clauses, int clleft, UInt nxtlbl)
2147 {
2148 PredEntry *ap = cint->CurrentPred;
2149 yamop *clcode;
2150 compiler_vm_op comp_op;
2151
2152 if (ap->PredFlags & LogUpdatePredFlag) {
2153 clcode = cl->Code;
2154 } else if (ap->PredFlags & TabledPredFlag) {
2155 clcode = NEXTOP(cl->Code,Otapl);
2156 } else {
2157 clcode = cl->CurrentCode;
2158 }
2159
2160 comp_op = emit_optry(var_group, first, clauses, clleft, cint->CurrentPred);
2161 Yap_emit(comp_op, (CELL)clcode, ((clauses+clleft) << 1) | has_cut(cl->CurrentCode), cint);
2162 }
2163
2164 static TypeSwitch *
emit_type_switch(compiler_vm_op op,struct intermediates * cint)2165 emit_type_switch(compiler_vm_op op, struct intermediates *cint)
2166 {
2167 return (TypeSwitch *)Yap_emit_extra_size(op, 0, sizeof(TypeSwitch), cint);
2168 }
2169
2170
2171 static yamop *
emit_switch_space(UInt n,UInt item_size,struct intermediates * cint,CELL func_mask)2172 emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_mask)
2173 {
2174 PredEntry *ap = cint->CurrentPred;
2175
2176 if (ap->PredFlags & LogUpdatePredFlag) {
2177 UInt sz = sizeof(LogUpdIndex)+n*item_size;
2178 LogUpdIndex *cl = (LogUpdIndex *)Yap_AllocCodeSpace(sz);
2179 if (cl == NULL) {
2180 /* grow stack */
2181 save_machine_regs();
2182 siglongjmp(cint->CompilerBotch,2);
2183 }
2184 Yap_LUIndexSpace_SW += sz;
2185 cl->ClFlags = SwitchTableMask|LogUpdMask|func_mask;
2186 cl->ClSize = sz;
2187 cl->ClPred = cint->CurrentPred;
2188 /* insert into code chain */
2189 #ifdef LOW_PROF
2190 if (ProfilerOn &&
2191 Yap_OffLineProfiler) {
2192 Yap_inform_profiler_of_clause(cl->ClCode, (yamop*)((CODEADDR)cl+sz), ap, 1);
2193 }
2194 #endif /* LOW_PROF */
2195 return cl->ClCode;
2196 } else {
2197 UInt sz = sizeof(StaticIndex)+n*item_size;
2198 StaticIndex *cl = (StaticIndex *)Yap_AllocCodeSpace(sz);
2199 if (cl == NULL) {
2200 /* grow stack */
2201 save_machine_regs();
2202 siglongjmp(cint->CompilerBotch,2);
2203 }
2204 Yap_IndexSpace_SW += sz;
2205 cl->ClFlags = SwitchTableMask;
2206 cl->ClSize = sz;
2207 cl->ClPred = cint->CurrentPred;
2208 #ifdef LOW_PROF
2209 if (ProfilerOn &&
2210 Yap_OffLineProfiler) {
2211 Yap_inform_profiler_of_clause(cl->ClCode, (yamop*)((CODEADDR)cl+sz), ap, 1);
2212 }
2213 #endif /* LOW_PROF */
2214 return cl->ClCode;
2215 /* insert into code chain */
2216 }
2217 }
2218
2219 static AtomSwiEntry *
emit_cswitch(COUNT n,yamop * fail_l,struct intermediates * cint)2220 emit_cswitch(COUNT n, yamop *fail_l, struct intermediates *cint)
2221 {
2222 compiler_vm_op op;
2223 AtomSwiEntry *target;
2224
2225 if (n > MIN_HASH_ENTRIES) {
2226 COUNT cases = MIN_HASH_ENTRIES, i;
2227 n += 1+n/4;
2228 while (cases < n) cases *= 2;
2229 n = cases;
2230 op = switch_c_op;
2231 target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint, 0);
2232 for (i=0; i<n; i++) {
2233 target[i].Tag = Zero;
2234 target[i].u.labp = fail_l;
2235 }
2236 Yap_emit(op, Unsigned(n), (CELL)target, cint);
2237 } else {
2238 UInt i;
2239
2240 op = if_c_op;
2241 target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
2242
2243 for (i=0; i<n; i++) {
2244 target[i].u.labp = fail_l;
2245 }
2246 target[n].Tag = Zero;
2247 target[n].u.labp = fail_l;
2248 Yap_emit(op, Unsigned(n), (CELL)target, cint);
2249 }
2250 return target;
2251 }
2252
2253 static AtomSwiEntry *
lookup_c_hash(Term t,yamop * tab,COUNT entries)2254 lookup_c_hash(Term t, yamop *tab, COUNT entries)
2255 {
2256 AtomSwiEntry *cebase = (AtomSwiEntry *)tab;
2257 int hash, d;
2258 AtomSwiEntry *centry;
2259
2260 hash = (t >> HASH_SHIFT) & (entries-1);
2261 centry = cebase + hash;
2262 d = (entries-1) & (t|1);
2263 while (centry->Tag != t) {
2264 if (centry->Tag == 0L)
2265 return centry;
2266 hash = (hash + d) & (entries-1);
2267 centry = cebase + hash;
2268 }
2269 return centry;
2270 }
2271
2272 static AtomSwiEntry *
fetch_centry(AtomSwiEntry * cebase,Term wt,int i,int n)2273 fetch_centry(AtomSwiEntry *cebase, Term wt, int i, int n)
2274 {
2275 if (n > MIN_HASH_ENTRIES) {
2276 int cases = MIN_HASH_ENTRIES;
2277
2278 n += 1+n/4;
2279 while (cases < n) cases *= 2;
2280 return lookup_c_hash(wt, (yamop *)cebase, cases);
2281 } else {
2282 return cebase + i;
2283 }
2284 }
2285
2286 static FuncSwiEntry *
emit_fswitch(COUNT n,yamop * fail_l,struct intermediates * cint)2287 emit_fswitch(COUNT n, yamop *fail_l, struct intermediates *cint)
2288 {
2289 compiler_vm_op op;
2290 FuncSwiEntry *target;
2291
2292 if (n > MIN_HASH_ENTRIES) {
2293 int cases = MIN_HASH_ENTRIES, i;
2294 n += 1+n/4;
2295 while (cases < n) cases *= 2;
2296 n = cases;
2297 op = switch_f_op;
2298 target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
2299 for (i=0; i<n; i++) {
2300 target[i].Tag = NULL;
2301 target[i].u.labp = fail_l;
2302 }
2303 Yap_emit(op, Unsigned(n), (CELL)target, cint);
2304 } else {
2305 UInt i;
2306
2307 op = if_f_op;
2308 target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
2309 for (i=0; i<n; i++) {
2310 target[i].u.labp = fail_l;
2311 }
2312 target[n].Tag = NULL;
2313 target[n].u.labp = fail_l;
2314 Yap_emit(op, Unsigned(n), (CELL)target, cint);
2315 }
2316 return target;
2317 }
2318
2319 static FuncSwiEntry *
lookup_f_hash(Functor f,yamop * tab,COUNT entries)2320 lookup_f_hash(Functor f, yamop *tab, COUNT entries)
2321 {
2322 FuncSwiEntry *febase = (FuncSwiEntry *)tab;
2323 int hash, d;
2324 FuncSwiEntry *fentry;
2325 Term wt = (Term)f;
2326
2327 hash = (wt >> HASH_SHIFT) & (entries-1);
2328 fentry = febase + hash;
2329 d = (entries-1) & (wt|1);
2330 while (fentry->Tag != f) {
2331 if (fentry->Tag == NULL)
2332 return fentry;
2333 hash = (hash + d) & (entries-1);
2334 fentry = febase + hash;
2335 }
2336 return fentry;
2337 }
2338
2339 static FuncSwiEntry *
fetch_fentry(FuncSwiEntry * febase,Functor ft,int i,int n)2340 fetch_fentry(FuncSwiEntry *febase, Functor ft, int i, int n)
2341 {
2342 if (n > MIN_HASH_ENTRIES) {
2343 int cases = MIN_HASH_ENTRIES;
2344
2345 n += 1+n/4;
2346 while (cases < n) cases *= 2;
2347 return lookup_f_hash(ft, (yamop *)febase, cases);
2348 } else {
2349 return febase + i;
2350 }
2351 }
2352
2353 /* we assume there is at least one clause, that is, c0 < cf */
2354 static UInt
do_var_clauses(ClauseDef * c0,ClauseDef * cf,int var_group,struct intermediates * cint,int first,int clleft,UInt nxtlbl,UInt argno0)2355 do_var_clauses(ClauseDef *c0, ClauseDef *cf, int var_group, struct intermediates *cint, int first, int clleft, UInt nxtlbl, UInt argno0) {
2356 UInt labl;
2357 UInt labl_dyn0 = 0, labl_dynf = 0;
2358
2359 labl = new_label(cint);
2360 Yap_emit(label_op, labl, Zero, cint);
2361 /*
2362 add expand_node if var_group == TRUE (jump on var) ||
2363 var_group == FALSE (leaf node)
2364 */
2365 if (first &&
2366 cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
2367 UInt ncls;
2368 labl_dyn0 = new_label(cint);
2369 if (clleft)
2370 labl_dynf = labl_dyn0;
2371 else
2372 labl_dynf = new_label(cint);
2373 if (clleft == 0) /* trust*/
2374 ncls = (cf-c0)+1;
2375 else
2376 ncls = 0;
2377 Yap_emit_4ops(enter_lu_op, labl_dyn0, labl_dynf, ncls, Zero, cint);
2378 Yap_emit(label_op, labl_dyn0, Zero, cint);
2379 }
2380 if (c0 == cf) {
2381 emit_try(c0, cint, var_group, first, 0, clleft, nxtlbl);
2382 } else {
2383
2384 if (c0 < cf) {
2385 emit_try(c0, cint, var_group, first, cf-c0, clleft, nxtlbl);
2386 }
2387 c0++;
2388 while (c0 < cf) {
2389 emit_retry(c0, cint, clleft+(cf-c0));
2390 c0++;
2391 }
2392 if (c0 == cf) {
2393 emit_trust(c0, cint, nxtlbl, clleft);
2394 if (!clleft &&
2395 cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
2396 Yap_emit(label_op, labl_dynf, Zero, cint);
2397 }
2398 }
2399 }
2400 return labl;
2401 }
2402
2403 static UInt
do_var_group(GroupDef * grp,struct intermediates * cint,int var_group,int first,int clleft,UInt nxtlbl,UInt argno0)2404 do_var_group(GroupDef *grp, struct intermediates *cint, int var_group, int first, int clleft, UInt nxtlbl, UInt argno0) {
2405 return do_var_clauses(grp->FirstClause, grp->LastClause, var_group, cint, first, clleft, nxtlbl, argno0);
2406 }
2407
2408
2409 /* count the number of different constants */
2410 static UInt
count_consts(GroupDef * grp)2411 count_consts(GroupDef *grp)
2412 {
2413 Term current = MkAtomTerm(AtomFoundVar);
2414 UInt i = 0;
2415 ClauseDef *cl = grp->FirstClause;
2416
2417 while (IsAtomTerm(cl->Tag) || IsIntTerm(cl->Tag)) {
2418 if (current != cl->Tag) {
2419 i++;
2420 current = cl->Tag;
2421 }
2422 if (cl == grp->LastClause) {
2423 return i;
2424 }
2425 cl++;
2426 }
2427 return i;
2428 }
2429
2430 static UInt
count_blobs(GroupDef * grp)2431 count_blobs(GroupDef *grp)
2432 {
2433 UInt i = 1;
2434 ClauseDef *cl = grp->FirstClause+1;
2435 Term current = grp->FirstClause->Tag;
2436
2437 while (cl <= grp->LastClause) {
2438 if (current != cl->Tag) {
2439 i++;
2440 current = cl->Tag;
2441 }
2442 cl++;
2443 }
2444 return i;
2445 }
2446
2447 /* count the number of different constants */
2448 static UInt
count_funcs(GroupDef * grp)2449 count_funcs(GroupDef *grp)
2450 {
2451 Term current = MkAtomTerm(AtomFoundVar);
2452 UInt i = 0;
2453 ClauseDef *cl = grp->FirstClause;
2454
2455 while (IsApplTerm(cl->Tag)) {
2456 if (current != cl->Tag) {
2457 i++;
2458 current = cl->Tag;
2459 }
2460 if (cl == grp->LastClause) {
2461 return i;
2462 }
2463 cl++;
2464 }
2465 return i;
2466 }
2467
2468 static UInt
emit_single_switch_case(ClauseDef * min,struct intermediates * cint,int first,int clleft,UInt nxtlbl)2469 emit_single_switch_case(ClauseDef *min, struct intermediates *cint, int first, int clleft, UInt nxtlbl)
2470 {
2471 if (cint->CurrentPred->PredFlags & TabledPredFlag) {
2472 /* with tabling we don't clean trust at the very end of computation.
2473 */
2474 if (clleft || !first) {
2475 /*
2476 if we still have clauses left, means we already created a CP,
2477 so I should avoid creating again
2478 */
2479 return (UInt)NEXTOP(min->Code,Otapl);
2480 } else {
2481 return (UInt)min->Code;
2482 }
2483 }
2484 if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
2485 return (UInt)(min->Code);
2486 } else {
2487 return (UInt)(min->CurrentCode);
2488 }
2489 }
2490
2491 static UInt
suspend_indexing(ClauseDef * min,ClauseDef * max,PredEntry * ap,struct intermediates * cint)2492 suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermediates *cint)
2493 {
2494 UInt tcls = ap->cs.p_code.NOfClauses;
2495 UInt cls = (max-min)+1;
2496
2497 if (cint->expand_block &&
2498 cint->expand_block != (yamop *)(&(ap->cs.p_code.ExpandCode)) &&
2499 cint->expand_block->u.sssllp.s2 < 2*(max-min)) {
2500 cint->expand_block->u.sssllp.s3++;
2501 return (UInt)(cint->expand_block);
2502 }
2503 if (cls < tcls/8) {
2504 yamop *ncode;
2505 yamop **st;
2506 UInt tels;
2507 UInt sz;
2508
2509 if (ap->PredFlags & LogUpdatePredFlag) {
2510 /* give it some slack */
2511 tels = cls + 4;
2512 } else {
2513 tels = cls;
2514 }
2515 sz = (UInt)NEXTOP((yamop *)NULL,sssllp)+tels*sizeof(yamop *);
2516 if ((ncode = (yamop *)Yap_AllocCodeSpace(sz)) == NULL) {
2517 save_machine_regs();
2518 siglongjmp(cint->CompilerBotch, 2);
2519 }
2520 #if DEBUG
2521 Yap_ExpandClauses++;
2522 Yap_expand_clauses_sz += sz;
2523 #endif
2524 if (ap->PredFlags & LogUpdatePredFlag) {
2525 Yap_LUIndexSpace_EXT += sz;
2526 } else {
2527 Yap_IndexSpace_EXT += sz;
2528 }
2529 #ifdef LOW_PROF
2530 if (ProfilerOn &&
2531 Yap_OffLineProfiler) {
2532 Yap_inform_profiler_of_clause(ncode, NEXTOP(ncode,sssllp), ap, 1);
2533 }
2534 #endif /* LOW_PROF */
2535 /* create an expand_block */
2536 ncode->opc = Yap_opcode(_expand_clauses);
2537 ncode->u.sssllp.p = ap;
2538 ncode->u.sssllp.s1 = tels;
2539 ncode->u.sssllp.s2 = cls;
2540 ncode->u.sssllp.s3 = 1;
2541 st = (yamop **)NEXTOP(ncode,sssllp);
2542 while (min <= max) {
2543 *st++ = min->Code;
2544 min++;
2545 }
2546 while (cls < tels) {
2547 *st++ = NULL;
2548 cls++;
2549 }
2550 LOCK(ExpandClausesListLock);
2551 ncode->u.sssllp.snext = ExpandClausesFirst;
2552 ncode->u.sssllp.sprev = NULL;
2553 if (ExpandClausesFirst)
2554 ExpandClausesFirst->u.sssllp.sprev = ncode;
2555 ExpandClausesFirst = ncode;
2556 if (ExpandClausesLast == NULL)
2557 ExpandClausesLast = ncode;
2558 UNLOCK(ExpandClausesListLock);
2559 return (UInt)ncode;
2560 }
2561 return (UInt)&(ap->cs.p_code.ExpandCode);
2562 }
2563
2564 static void
recover_ecls_block(yamop * ipc)2565 recover_ecls_block(yamop *ipc)
2566 {
2567 ipc->u.sssllp.s3--;
2568 if (!ipc->u.sssllp.s3) {
2569 LOCK(ExpandClausesListLock);
2570 if (ExpandClausesFirst == ipc)
2571 ExpandClausesFirst = ipc->u.sssllp.snext;
2572 if (ExpandClausesLast == ipc) {
2573 ExpandClausesLast = ipc->u.sssllp.sprev;
2574 }
2575 if (ipc->u.sssllp.sprev) {
2576 ipc->u.sssllp.sprev->u.sssllp.snext = ipc->u.sssllp.snext;
2577 }
2578 if (ipc->u.sssllp.snext) {
2579 ipc->u.sssllp.snext->u.sssllp.sprev = ipc->u.sssllp.sprev;
2580 }
2581 UNLOCK(ExpandClausesListLock);
2582 #if DEBUG
2583 Yap_ExpandClauses--;
2584 Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sssllp))+ipc->u.sssllp.s1*sizeof(yamop *);
2585 #endif
2586 /* no dangling pointers for gprof */
2587 Yap_InformOfRemoval((CODEADDR)ipc);
2588 if (ipc->u.sssllp.p->PredFlags & LogUpdatePredFlag) {
2589 Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+ipc->u.sssllp.s1*sizeof(yamop *);
2590 } else
2591 Yap_IndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sssllp)+ipc->u.sssllp.s1*sizeof(yamop *);
2592 Yap_FreeCodeSpace((char *)ipc);
2593 }
2594 }
2595
2596 static UInt
do_var_entries(GroupDef * grp,Term t,struct intermediates * cint,UInt argno,int first,int clleft,UInt nxtlbl)2597 do_var_entries(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int clleft, UInt nxtlbl){
2598 PredEntry *ap = cint->CurrentPred;
2599
2600 if (!IsVarTerm(t) || t != 0L) {
2601 return suspend_indexing(grp->FirstClause, grp->LastClause, ap, cint);
2602 }
2603 return do_var_group(grp, cint, FALSE, first, clleft, nxtlbl, ap->ArityOfPE+1);
2604 }
2605
2606 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)2607 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)
2608 {
2609 COUNT n;
2610 ClauseDef *min = grp->FirstClause;
2611 COUNT i;
2612 UInt lbl;
2613 /* generate a switch */
2614 AtomSwiEntry *cs;
2615 PredEntry *ap = cint->CurrentPred;
2616
2617 if (!IsAtomTerm(min->Tag) && !IsIntTerm(min->Tag)) {
2618 /* no clauses, just skip */
2619 return nxtlbl;
2620 }
2621 n = count_consts(grp);
2622 lbl = new_label(cint);
2623 Yap_emit(label_op, lbl, Zero, cint);
2624 cs = emit_cswitch(n, FAILCODE, cint);
2625 for (i = 0; i < n; i++) {
2626 AtomSwiEntry *ics;
2627 ClauseDef *max = min;
2628
2629 ics = fetch_centry(cs, min->Tag, i, n);
2630 ics->Tag = min->Tag;
2631 while (max != grp->LastClause && (max+1)->Tag == min->Tag)
2632 max++;
2633 if (min != max) {
2634 if (sreg != NULL) {
2635 if (ap->PredFlags & LogUpdatePredFlag && max > min) {
2636 ics->u.Label = suspend_indexing(min, max, ap, cint);
2637 } else {
2638 ics->u.Label = do_compound_index(min, max, sreg, cint, compound_term, arity, argno, nxtlbl, first, last_arg, clleft, top, TRUE);
2639 }
2640 } else if (ap->PredFlags & LogUpdatePredFlag) {
2641 ics->u.Label = suspend_indexing(min, max, cint->CurrentPred, cint);
2642 } else {
2643 ics->u.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top);
2644 }
2645 } else {
2646 ics->u.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top);
2647 }
2648 grp->FirstClause = min = max+1;
2649 }
2650 return lbl;
2651 }
2652
2653 static void
do_blobs(GroupDef * grp,Term t,struct intermediates * cint,UInt argno,int first,UInt nxtlbl,int clleft,CELL * top)2654 do_blobs(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, UInt nxtlbl, int clleft, CELL *top)
2655 {
2656 COUNT n;
2657 ClauseDef *min = grp->FirstClause;
2658 COUNT i;
2659 /* generate a switch */
2660 AtomSwiEntry *cs;
2661 PredEntry *ap = cint->CurrentPred;
2662
2663 n = count_blobs(grp);
2664 cs = emit_cswitch(n, (yamop *)nxtlbl, cint);
2665 for (i = 0; i < n; i++) {
2666 AtomSwiEntry *ics;
2667 ClauseDef *max = min;
2668
2669 ics = fetch_centry(cs, min->Tag, i, n);
2670 ics->Tag = min->Tag;
2671 while (max != grp->LastClause &&
2672 (max+1)->Tag == min->Tag) max++;
2673 if (min != max &&
2674 (ap->PredFlags & LogUpdatePredFlag)) {
2675 ics->u.Label = suspend_indexing(min, max, ap, cint);
2676 } else {
2677 ics->u.Label = do_index(min, max, cint, argno+1, nxtlbl, first, clleft, top);
2678 }
2679 grp->FirstClause = min = max+1;
2680 }
2681 }
2682
2683 static UInt
do_funcs(GroupDef * grp,Term t,struct intermediates * cint,UInt argno,int first,int last_arg,UInt nxtlbl,int clleft,CELL * top)2684 do_funcs(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top)
2685 {
2686 COUNT n = count_funcs(grp);
2687 ClauseDef *min = grp->FirstClause;
2688 COUNT i;
2689 FuncSwiEntry *fs;
2690 UInt lbl;
2691
2692 if (min > grp->LastClause || n == 0) {
2693 /* no clauses, just skip */
2694 return nxtlbl;
2695 }
2696 lbl = new_label(cint);
2697 Yap_emit(label_op, lbl, Zero, cint);
2698 /* generate a switch */
2699 fs = emit_fswitch(n, FAILCODE, cint);
2700 for (i = 0; i < n ; i++) {
2701 Functor f = (Functor)RepAppl(min->Tag);
2702 FuncSwiEntry *ifs;
2703 ClauseDef *max = min;
2704
2705 ifs = fetch_fentry(fs, f, i, n);
2706 ifs->Tag = f;
2707 while (max != grp->LastClause && (max+1)->Tag == min->Tag)
2708 max++;
2709 /* delay non-trivial indexing
2710 if (min != max &&
2711 !IsExtensionFunctor(f)) {
2712 ifs->u.Label = suspend_indexing(min, max, ap, cint);
2713 } else
2714 */
2715
2716 if (IsExtensionFunctor(f)) {
2717 if (f == FunctorDBRef)
2718 ifs->u.Label = do_dbref_index(min, max, t, cint, argno, nxtlbl, first, clleft, top);
2719 else if (f == FunctorLongInt || f == FunctorBigInt)
2720 ifs->u.Label = do_blob_index(min, max, t, cint, argno, nxtlbl, first, clleft, top, FALSE);
2721 else
2722 ifs->u.Label = do_blob_index(min, max, t, cint, argno, nxtlbl, first, clleft, top, TRUE);
2723
2724 } else {
2725 CELL *sreg;
2726
2727 if (!IsVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == f) {
2728 sreg = RepAppl(t)+1;
2729 } else {
2730 sreg = NULL;
2731 }
2732 ifs->u.Label = do_compound_index(min, max, sreg, cint, 0, ArityOfFunctor(f), argno, nxtlbl, first, last_arg, clleft, top, TRUE);
2733 }
2734 grp->FirstClause = min = max+1;
2735 }
2736 return lbl;
2737 }
2738
2739 static UInt
do_pair(GroupDef * grp,Term t,struct intermediates * cint,UInt argno,int first,int last_arg,UInt nxtlbl,int clleft,CELL * top)2740 do_pair(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int first, int last_arg, UInt nxtlbl, int clleft, CELL *top)
2741 {
2742 ClauseDef *min = grp->FirstClause;
2743 ClauseDef *max = grp->FirstClause;
2744
2745 while (IsPairTerm(max->Tag) && max != grp->LastClause) {
2746 max++;
2747 }
2748 if (!IsPairTerm(max->Tag)) {
2749 max--;
2750 }
2751 if (min > grp->LastClause) {
2752 /* no clauses, just skip */
2753 return nxtlbl;
2754 }
2755 grp->FirstClause = max+1;
2756 if (min == max) {
2757 /* single clause, no need to do indexing, but we do know it is a list */
2758 if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
2759 return (UInt)(min->Code);
2760 } else {
2761 return (UInt)(min->CurrentCode);
2762 }
2763 }
2764 if (min != max && !IsPairTerm(t)) {
2765 return suspend_indexing(min, max, cint->CurrentPred, cint);
2766 }
2767 return do_compound_index(min, max, (IsPairTerm(t) ? RepPair(t) : NULL), cint, 0, 2, argno, nxtlbl, first, last_arg, clleft, top, TRUE);
2768 }
2769
2770 static void
group_prologue(int compound_term,UInt argno,int first,struct intermediates * cint)2771 group_prologue(int compound_term, UInt argno, int first, struct intermediates *cint)
2772 {
2773 if (compound_term) {
2774 Yap_emit(cache_sub_arg_op, compound_term-1, compound_term-1, cint);
2775 } else {
2776 if (!first || argno != 1) {
2777 Yap_emit(cache_arg_op, argno, argno, cint);
2778 }
2779 }
2780 }
2781
2782 /* make sure that we can handle failure correctly */
2783 static void
emit_protection_choicepoint(int first,int clleft,UInt nxtlbl,struct intermediates * cint)2784 emit_protection_choicepoint(int first, int clleft, UInt nxtlbl, struct intermediates *cint)
2785 {
2786
2787 if (first) {
2788 if (clleft) {
2789 if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
2790 UInt labl = new_label(cint);
2791
2792 Yap_emit_4ops(enter_lu_op, labl, labl, 0, Zero, cint);
2793 Yap_emit(label_op, labl, Zero, cint);
2794 }
2795 Yap_emit(tryme_op, nxtlbl, (clleft << 1), cint);
2796 }
2797 } else {
2798 /* !first */
2799 if (clleft) {
2800 Yap_emit(retryme_op, nxtlbl, (clleft << 1), cint);
2801 } else {
2802 Yap_emit(trustme_op, 0, 0, cint);
2803 }
2804 }
2805 }
2806
2807
2808 static ClauseDef *
cls_move(ClauseDef * min,PredEntry * ap,ClauseDef * max,int compound_term,UInt argno,int last_arg)2809 cls_move(ClauseDef *min, PredEntry *ap, ClauseDef *max, int compound_term, UInt argno, int last_arg)
2810 {
2811 ClauseDef *cl=min;
2812
2813 cl = min;
2814 if (compound_term) {
2815 while (cl <= max) {
2816 skip_to_arg(cl, ap, compound_term, last_arg );
2817 cl++;
2818 }
2819 } else {
2820 while (cl <= max) {
2821 if (cl->Tag == (_var+1)*sizeof(CELL)) {
2822 ClauseDef *cli = cl;
2823 while (cli < max) {
2824 clcpy(cli,cli+1);
2825 cli++;
2826 }
2827 max--;
2828 } else {
2829 move_next(cl, argno);
2830 }
2831 cl++;
2832 }
2833 }
2834 return max;
2835 }
2836
2837 static void
purge_pvar(GroupDef * group)2838 purge_pvar(GroupDef *group) {
2839 ClauseDef *max = group->LastClause;
2840 ClauseDef *cl = group->FirstClause;
2841
2842 while (cl <= max) {
2843 if (cl->Tag == (_var+1)*sizeof(CELL)) {
2844 ClauseDef *cli = cl;
2845 while (cli < max) {
2846 clcpy(cli,cli+1);
2847 cli++;
2848 }
2849 group->VarClauses--;
2850 max--;
2851 }
2852 cl++;
2853 }
2854 group->LastClause = max;
2855 }
2856
2857
2858 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)2859 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) {
2860 TypeSwitch *type_sw;
2861 PredEntry *ap = cint->CurrentPred;
2862
2863
2864 /* move cl pointer */
2865 if (grp->AtomClauses + grp->PairClauses + grp->StructClauses > 1) {
2866 Yap_emit(label_op, labl, Zero, cint);
2867 if (argno == 1 && !compound_term) {
2868 emit_protection_choicepoint(first, clleft, nxtlbl, cint);
2869 }
2870 group_prologue(compound_term, argno, first, cint);
2871 if (grp->LastClause < grp->FirstClause) { /* only tests */
2872 return NULL;
2873 }
2874 type_sw = emit_type_switch(switch_on_type_op, cint);
2875 /* have these first so that we will have something initialised here */
2876 type_sw->ConstEntry =
2877 type_sw->FuncEntry =
2878 type_sw->PairEntry =
2879 type_sw->VarEntry =
2880 nxtlbl;
2881 type_sw->VarEntry = do_var_entries(grp, t, cint, argno, first, clleft, nxtlbl);
2882 grp->LastClause = cls_move(grp->FirstClause, ap, grp->LastClause, compound_term, argno, last_arg);
2883 sort_group(grp,top,cint);
2884 while (grp->FirstClause <= grp->LastClause) {
2885 if (IsAtomOrIntTerm(grp->FirstClause->Tag)) {
2886 type_sw->ConstEntry = do_consts(grp, t, cint, compound_term, sreg, arity, last_arg, argno, first, nxtlbl, clleft, top);
2887 } else if (IsApplTerm(grp->FirstClause->Tag)) {
2888 type_sw->FuncEntry = do_funcs(grp, t, cint, argno, first, last_arg, nxtlbl, clleft, top);
2889 } else {
2890 type_sw->PairEntry = do_pair(grp, t, cint, argno, first, last_arg, nxtlbl, clleft, top);
2891 }
2892 }
2893 return &(type_sw->VarEntry);
2894 } else {
2895 Yap_emit(label_op,labl,Zero, cint);
2896 do_var_group(grp, cint, TRUE, first, clleft, nxtlbl, ap->ArityOfPE+1);
2897 return NULL;
2898 }
2899 }
2900
2901 static UInt
do_optims(GroupDef * group,int ngroups,UInt fail_l,ClauseDef * min,struct intermediates * cint)2902 do_optims(GroupDef *group, int ngroups, UInt fail_l, ClauseDef *min, struct intermediates *cint)
2903 {
2904 if (ngroups==2 && group[0].FirstClause == group[0].LastClause &&
2905 group[0].AtomClauses == 1 && group[1].VarClauses == 1) {
2906 CELL *sp;
2907 UInt labl;
2908
2909 labl = new_label(cint);
2910 sp = Yap_emit_extra_size(if_not_op, Zero, 4*CellSize, cint);
2911 sp[0] = (CELL)(group[0].FirstClause->Tag);
2912 sp[1] = (CELL)(group[1].FirstClause->Code);
2913 sp[2] = do_var_clauses(group[0].FirstClause, group[1].LastClause, FALSE, cint, TRUE, 0, (CELL)FAILCODE, cint->CurrentPred->ArityOfPE+1);
2914 sp[3] = do_var_clauses(min, group[1].LastClause, FALSE, cint, TRUE, 0, (CELL)FAILCODE, cint->CurrentPred->ArityOfPE+1);
2915 return labl;
2916 }
2917 return fail_l;
2918 }
2919
2920 static int
cls_info(ClauseDef * min,ClauseDef * max,UInt argno)2921 cls_info(ClauseDef *min, ClauseDef *max, UInt argno)
2922 {
2923 ClauseDef *cl=min;
2924 int found_pvar = FALSE;
2925
2926 while (cl <= max) {
2927 add_info(cl, argno);
2928 if (cl->Tag == (_var+1)*sizeof(CELL)) {
2929 found_pvar = TRUE;
2930 }
2931 /* if (IsVarTerm(cl->Tag)) cl->Tag = (CELL)NULL; */
2932 cl++;
2933 }
2934 return found_pvar;
2935 }
2936
2937 static int
cls_head_info(ClauseDef * min,ClauseDef * max,UInt argno,int in_idb)2938 cls_head_info(ClauseDef *min, ClauseDef *max, UInt argno, int in_idb)
2939 {
2940 ClauseDef *cl=min;
2941
2942 if (in_idb) {
2943 if (argno != 2) {
2944 while (cl <= max) {
2945 cl->Tag = (CELL)NULL;
2946 cl++;
2947 }
2948 } else {
2949 while (cl <= max) {
2950 LogUpdClause *lcl = ClauseCodeToLogUpdClause(cl->CurrentCode);
2951 Term t = lcl->ClSource->Entry;
2952
2953 if (IsVarTerm(t)) {
2954 cl->Tag = (CELL)NULL;
2955 } else if (IsApplTerm(t)) {
2956 CELL *pt = RepAppl(t);
2957
2958 cl->Tag = AbsAppl((CELL *)pt[0]);
2959 if (IsExtensionFunctor(FunctorOfTerm(t))) {
2960 cl->u.t_ptr = t;
2961 } else {
2962 cl->u.c_sreg = pt;
2963 }
2964 } else if (IsPairTerm(t)) {
2965 CELL *pt = RepPair(t);
2966
2967 cl->Tag = AbsPair(NULL);
2968 cl->u.c_sreg = pt-1;
2969 } else {
2970 cl->Tag = t;
2971 }
2972 cl++;
2973 }
2974 }
2975 } else {
2976 while (cl <= max) {
2977 add_head_info(cl, argno);
2978 /* if (IsVarTerm(cl->Tag)) cl->Tag = (CELL)NULL; */
2979 cl++;
2980 }
2981 }
2982 return FALSE;
2983 }
2984
2985 static UInt
do_index(ClauseDef * min,ClauseDef * max,struct intermediates * cint,UInt argno,UInt fail_l,int first,int clleft,CELL * top)2986 do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno, UInt fail_l, int first, int clleft, CELL *top)
2987 {
2988 UInt ngroups, found_pvar = FALSE;
2989 UInt i = 0;
2990 GroupDef *group = (GroupDef *)top;
2991 UInt labl, labl0, lablx;
2992 Term t;
2993 /* remember how we entered here */
2994 UInt argno0 = argno;
2995 PredEntry *ap = cint->CurrentPred;
2996 yamop *eblk = cint->expand_block;
2997
2998 if (min == max) {
2999 /* base case, just commit to the current code */
3000 return emit_single_switch_case(min, cint, first, clleft, fail_l);
3001 }
3002 if ((argno > 1 && yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE && ap->PredFlags & LogUpdatePredFlag) ||
3003 yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_OFF ||
3004 ap->ArityOfPE < argno) {
3005 return do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1);
3006 }
3007 t = Deref(XREGS[argno]);
3008 if (ap->PredFlags & LogUpdatePredFlag) {
3009 found_pvar = cls_head_info(min, max, argno, (ap->ModuleOfPred == IDB_MODULE));
3010 } else {
3011 found_pvar = cls_info(min, max, argno);
3012 }
3013 ngroups = groups_in(min, max, group, cint);
3014 if (IsVarTerm(t)) {
3015 lablx = new_label(cint);
3016 Yap_emit(label_op, lablx, Zero, cint);
3017 while (IsVarTerm(t)) {
3018 if (ngroups > 1 || !group->VarClauses) {
3019 UInt susp_lab = suspend_indexing(min, max, ap, cint);
3020 if (!cint->expand_block) {
3021 cint->expand_block = (yamop *)susp_lab;
3022 }
3023 Yap_emit(jump_nv_op, susp_lab, argno, cint);
3024 }
3025 if (argno == ap->ArityOfPE ||
3026 (yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE &&
3027 ap->PredFlags & LogUpdatePredFlag)) {
3028 do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, argno0);
3029 cint->expand_block = eblk;
3030 return lablx;
3031 }
3032 argno++;
3033 t = Deref(XREGS[argno]);
3034 if (ap->PredFlags & LogUpdatePredFlag) {
3035 found_pvar = cls_head_info(min, max, argno, (ap->ModuleOfPred == IDB_MODULE) );
3036 } else {
3037 found_pvar = cls_info(min, max, argno);
3038 }
3039 ngroups = groups_in(min, max, group, cint);
3040 }
3041 labl0 = labl = new_label(cint);
3042 } else {
3043 lablx = labl0 = labl = new_label(cint);
3044 }
3045 cint->expand_block = eblk;
3046 top = (CELL *)(group+ngroups);
3047 if (argno > 1) {
3048 /* don't try being smart for other arguments than the first */
3049 if (ngroups > 1 || group->VarClauses != 0 || found_pvar) {
3050 if (ap->ArityOfPE == argno) {
3051 return do_var_clauses(min, max, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1);
3052 } else {
3053 return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
3054 }
3055 } else {
3056 ClauseDef *cl = min;
3057 /*
3058 need to reset the code pointer, otherwise I could be in
3059 the middle of a compound term.
3060 */
3061 while (cl <= max) {
3062 cl->CurrentCode = cl->Code;
3063 cl++;
3064 }
3065 }
3066 } else {
3067 UInt special_options;
3068
3069 if ((ap->PredFlags & LogUpdatePredFlag) && ngroups > 1) {
3070 if (ngroups > 1) {
3071 group[0].VarClauses = ap->cs.p_code.NOfClauses;
3072 group[0].AtomClauses =
3073 group[0].PairClauses =
3074 group[0].StructClauses =
3075 group[0].TestClauses = 0;
3076 group[0].LastClause = group[ngroups-1].LastClause;
3077 ngroups = 1;
3078 }
3079 } else if ((special_options = do_optims(group, ngroups, fail_l, min, cint)) != fail_l) {
3080 return special_options;
3081 }
3082 if (ngroups == 1 && group->VarClauses && !found_pvar) {
3083 return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
3084 } else if (found_pvar ||
3085 (ap->PredFlags & LogUpdatePredFlag && group[0].VarClauses)) {
3086 /* make sure we know where to suspend */
3087 Yap_emit(label_op, labl0, Zero, cint);
3088 labl = new_label(cint);
3089 Yap_emit(jump_v_op, suspend_indexing(min, max, ap, cint), Zero, cint);
3090 }
3091 }
3092 for (i=0; i < ngroups; i++) {
3093 UInt nextlbl;
3094 int left_clauses = clleft+(max-group->LastClause);
3095 /* a group may end up not having clauses*/
3096
3097 if (i < ngroups-1) {
3098 nextlbl = new_label(cint);
3099 } else {
3100 nextlbl = fail_l;
3101 }
3102 if (found_pvar && argno == 1) {
3103 purge_pvar(group);
3104 }
3105 if (group->FirstClause==group->LastClause && first && left_clauses == 0) {
3106 Yap_emit(jumpi_op, (CELL)(group->FirstClause->Code), Zero, cint);
3107 } else {
3108 if (group->VarClauses) {
3109 Yap_emit(label_op,labl,Zero, cint);
3110 do_var_group(group, cint, argno == 1, first, left_clauses, nextlbl, ap->ArityOfPE+1);
3111 } else {
3112 do_nonvar_group(group, t, 0, NULL, 0, labl, cint, argno, first, TRUE, nextlbl, left_clauses, top);
3113 }
3114 }
3115 first = FALSE;
3116 group++;
3117 labl = nextlbl;
3118 }
3119 return lablx;
3120 }
3121
3122 static ClauseDef *
copy_clauses(ClauseDef * max0,ClauseDef * min0,CELL * top,struct intermediates * cint)3123 copy_clauses(ClauseDef *max0, ClauseDef *min0, CELL *top, struct intermediates *cint)
3124 {
3125 UInt sz = ((max0+1)-min0)*sizeof(ClauseDef);
3126 if ((char *)top + sz >= Yap_TrailTop-4096) {
3127 Yap_Error_Size = sz;
3128 /* grow stack */
3129 save_machine_regs();
3130 siglongjmp(cint->CompilerBotch,4);
3131 }
3132 memcpy((void *)top, (void *)min0, sz);
3133 return (ClauseDef *)top;
3134 }
3135
3136
3137 /* execute an index inside a structure */
3138 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)3139 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)
3140 {
3141 UInt ret_lab = 0, *newlabp;
3142 CELL *top0 = top;
3143 ClauseDef *min, *max;
3144 PredEntry *ap = cint->CurrentPred;
3145 int found_index = FALSE, lu_pred = ap->PredFlags & LogUpdatePredFlag;
3146
3147 newlabp = & ret_lab;
3148 if (min0 == max0) {
3149 /* base case, just commit to the current code */
3150 return emit_single_switch_case(min0, cint, first, clleft, fail_l);
3151 }
3152 if (yap_flags[INDEXING_MODE_FLAG] == INDEX_MODE_SINGLE && ap->PredFlags & LogUpdatePredFlag) {
3153 *newlabp =
3154 do_var_clauses(min0, max0, FALSE, cint, first, clleft, fail_l, ap->ArityOfPE+1);
3155 return ret_lab;
3156 }
3157 if (sreg == NULL) {
3158 return suspend_indexing(min0, max0, ap, cint);
3159 }
3160 while (i < arity && !found_index) {
3161 ClauseDef *cl;
3162 GroupDef *group;
3163 UInt ngroups;
3164 int isvt = IsVarTerm(Deref(sreg[i]));
3165
3166 min = copy_clauses(max0, min0, top, cint);
3167 max = min+(max0-min0);
3168 top = (CELL *)(max+1);
3169 cl = min;
3170 /* search for a subargument */
3171 while (cl <= max) {
3172 add_arg_info(cl, ap, i+1);
3173 cl++;
3174 }
3175 group = (GroupDef *)top;
3176 ngroups = groups_in(min, max, group, cint);
3177 if (ngroups == 1 && group->VarClauses == 0) {
3178 /* ok, we are doing a sub-argument */
3179 /* process group */
3180
3181 found_index = TRUE;
3182 ret_lab = new_label(cint);
3183 top = (CELL *)(group+1);
3184 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) {
3185 top = top0;
3186 break;
3187 }
3188 }
3189 top = top0;
3190 i++;
3191 }
3192 if (!found_index) {
3193 if (!lu_pred || !done_work)
3194 *newlabp = do_index(min0, max0, cint, argno+1, fail_l, first, clleft, top);
3195 else
3196 *newlabp = suspend_indexing(min0, max0, ap, cint);
3197 }
3198 return ret_lab;
3199 }
3200
3201 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)3202 do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint, UInt argno, UInt fail_l, int first, int clleft, CELL *top)
3203 {
3204 UInt ngroups;
3205 GroupDef *group;
3206 ClauseDef *cl = min;
3207
3208 group = (GroupDef *)top;
3209 cl = min;
3210
3211 while (cl <= max) {
3212 cl->Tag = cl->u.t_ptr;
3213 cl++;
3214 }
3215 ngroups = groups_in(min, max, group, cint);
3216 if (ngroups > 1 || group->VarClauses) {
3217 return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
3218 } else {
3219 int labl = new_label(cint);
3220
3221 Yap_emit(label_op, labl, Zero, cint);
3222 Yap_emit(index_dbref_op, Zero, Zero, cint);
3223 sort_group(group,(CELL *)(group+1),cint);
3224 do_blobs(group, t, cint, argno, first, fail_l, clleft, (CELL *)(group+1));
3225 return labl;
3226 }
3227 }
3228
3229 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)3230 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)
3231 {
3232 UInt ngroups;
3233 GroupDef *group;
3234 ClauseDef *cl = min;
3235
3236 group = (GroupDef *)top;
3237 cl = min;
3238
3239 while (cl <= max) {
3240 if (cl->u.t_ptr == (CELL)NULL) { /* check whether it is a builtin */
3241 cl->Tag = Zero;
3242 } else if (blob) {
3243 cl->Tag = Yap_Double_key(cl->u.t_ptr);
3244 } else {
3245 cl->Tag = Yap_Int_key(cl->u.t_ptr);
3246 }
3247 cl++;
3248 }
3249 ngroups = groups_in(min, max, group, cint);
3250 if (ngroups > 1 || group->VarClauses) {
3251 return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
3252 } else {
3253 int labl = new_label(cint);
3254
3255 Yap_emit(label_op, labl, Zero, cint);
3256 if (blob)
3257 Yap_emit(index_blob_op, Zero, Zero, cint);
3258 else
3259 Yap_emit(index_long_op, Zero, Zero, cint);
3260 sort_group(group,(CELL *)(group+1),cint);
3261 do_blobs(group, t, cint, argno, first, fail_l, clleft, (CELL *)(group+1));
3262 return labl;
3263 }
3264 }
3265
3266 static void
init_clauses(ClauseDef * cl,PredEntry * ap)3267 init_clauses(ClauseDef *cl, PredEntry *ap)
3268 {
3269 if (ap->PredFlags & MegaClausePredFlag) {
3270 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
3271 yamop *end = (yamop *)((char *)mcl->ClCode+mcl->ClSize);
3272 yamop *cd = mcl->ClCode;
3273 while (cd < end) {
3274 cl->Code = cl->CurrentCode = cd;
3275 cd = (yamop *)((char *)cd+mcl->ClItemSize);
3276 cl++;
3277 }
3278 } else {
3279 StaticClause *scl;
3280
3281 scl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
3282 do {
3283 cl->Code = cl->CurrentCode = scl->ClCode;
3284 cl++;
3285 if (scl->ClCode == ap->cs.p_code.LastClause)
3286 return;
3287 scl = scl->ClNext;
3288 } while (TRUE);
3289 }
3290 }
3291
3292 static void
init_log_upd_clauses(ClauseDef * cl,PredEntry * ap)3293 init_log_upd_clauses(ClauseDef *cl, PredEntry *ap)
3294 {
3295 LogUpdClause *lcl = ClauseCodeToLogUpdClause(ap->cs.p_code.FirstClause);
3296
3297 do {
3298 cl->Code = cl->CurrentCode = lcl->ClCode;
3299 cl++;
3300 lcl = lcl->ClNext;
3301 } while (lcl != NULL);
3302 }
3303
3304 static UInt
compile_index(struct intermediates * cint)3305 compile_index(struct intermediates *cint)
3306 {
3307 PredEntry *ap = cint->CurrentPred;
3308 int NClauses = ap->cs.p_code.NOfClauses;
3309 CELL *top = (CELL *) TR;
3310 UInt res;
3311
3312 /* only global variable I use directly */
3313 cint->i_labelno = 1;
3314
3315 Yap_Error_Size = 0;
3316 #if USE_SYSTEM_MALLOC
3317 if (!cint->cls) {
3318 cint->cls = (ClauseDef *)Yap_AllocCodeSpace(NClauses*sizeof(ClauseDef));
3319 if (!cint->cls) {
3320 /* tell how much space we need */
3321 Yap_Error_Size += NClauses*sizeof(ClauseDef);
3322 /* grow stack */
3323 save_machine_regs();
3324 siglongjmp(cint->CompilerBotch,2);
3325 }
3326 }
3327 cint->freep = (char *)H;
3328 #else
3329 /* reserve double the space for compiler */
3330 cint->cls = (ClauseDef *)H;
3331 if (cint->cls+2*NClauses > (ClauseDef *)(ASP-4096)) {
3332 /* tell how much space we need */
3333 Yap_Error_Size += NClauses*sizeof(ClauseDef);
3334 /* grow stack */
3335 save_machine_regs();
3336 siglongjmp(cint->CompilerBotch,3);
3337 }
3338 cint->freep = (char *)(cint->cls+NClauses);
3339 #endif
3340 if (ap->PredFlags & LogUpdatePredFlag) {
3341 /* throw away a label */
3342 new_label(cint);
3343 init_log_upd_clauses(cint->cls,ap);
3344 } else if (ap->PredFlags & UDIPredFlag) {
3345 UInt lbl = new_label(cint);
3346 Yap_emit(user_switch_op, Unsigned(ap), Unsigned(&(ap->cs.p_code.ExpandCode)), cint);
3347 return lbl;
3348 } else {
3349 /* prepare basic data structures */
3350 init_clauses(cint->cls,ap);
3351 }
3352 res = do_index(cint->cls, cint->cls+(NClauses-1), cint, 1, (UInt)FAILCODE, TRUE, 0, top);
3353 return res;
3354 }
3355
3356 static void
CleanCls(struct intermediates * cint)3357 CleanCls(struct intermediates *cint)
3358 {
3359 #if USE_SYSTEM_MALLOC
3360 if (cint->cls) {
3361 Yap_FreeCodeSpace((ADDR)cint->cls);
3362 }
3363 #endif
3364 cint->cls = NULL;
3365 }
3366
3367 yamop *
Yap_PredIsIndexable(PredEntry * ap,UInt NSlots,yamop * next_pc)3368 Yap_PredIsIndexable(PredEntry *ap, UInt NSlots, yamop *next_pc)
3369 {
3370 yamop *indx_out;
3371 int setjres;
3372 struct intermediates cint;
3373
3374
3375 cint.CurrentPred = ap;
3376 cint.code_addr = NULL;
3377 cint.blks = NULL;
3378 cint.cls = NULL;
3379 Yap_Error_Size = 0;
3380
3381 if ((setjres = sigsetjmp(cint.CompilerBotch, 0)) == 3) {
3382 restore_machine_regs();
3383 recover_from_failed_susp_on_cls(&cint, 0);
3384 if (!Yap_gcl(Yap_Error_Size, ap->ArityOfPE+NSlots, ENV, next_pc)) {
3385 CleanCls(&cint);
3386 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
3387 return FAILCODE;
3388 }
3389 } else if (setjres == 2) {
3390 restore_machine_regs();
3391 Yap_Error_Size = recover_from_failed_susp_on_cls(&cint, Yap_Error_Size);
3392 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
3393 CleanCls(&cint);
3394 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
3395 return FAILCODE;
3396 }
3397 } else if (setjres == 4) {
3398 restore_machine_regs();
3399 recover_from_failed_susp_on_cls(&cint, 0);
3400 if (!Yap_growtrail(Yap_Error_Size, FALSE)) {
3401 CleanCls(&cint);
3402 Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, Yap_ErrorMessage);
3403 return FAILCODE;
3404 }
3405 } else if (setjres != 0) {
3406 restore_machine_regs();
3407 recover_from_failed_susp_on_cls(&cint, 0);
3408 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
3409 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
3410 CleanCls(&cint);
3411 return FAILCODE;
3412 }
3413 }
3414 restart_index:
3415 Yap_BuildMegaClause(ap);
3416 cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NULL;
3417 cint.expand_block = NULL;
3418 cint.label_offset = NULL;
3419 Yap_ErrorMessage = NULL;
3420 if (compile_index(&cint) == (UInt)FAILCODE) {
3421 Yap_ReleaseCMem(&cint);
3422 CleanCls(&cint);
3423 return FAILCODE;
3424 }
3425 #ifdef DEBUG
3426 if (Yap_Option['i' - 'a' + 1]) {
3427 Yap_LockStream(Yap_c_error_stream);
3428 Yap_ShowCode(&cint);
3429 Yap_UnLockStream(Yap_c_error_stream);
3430 }
3431 #endif
3432 /* globals for assembler */
3433 IPredArity = ap->ArityOfPE;
3434 if (cint.CodeStart) {
3435 if ((indx_out = Yap_assemble(ASSEMBLING_INDEX, TermNil, ap, FALSE, &cint, cint.i_labelno+1)) == NULL) {
3436 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
3437 Yap_ReleaseCMem(&cint);
3438 CleanCls(&cint);
3439 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
3440 return NULL;
3441 }
3442 goto restart_index;
3443 }
3444 } else {
3445 Yap_ReleaseCMem(&cint);
3446 CleanCls(&cint);
3447 return NULL;
3448 }
3449 Yap_ReleaseCMem(&cint);
3450 CleanCls(&cint);
3451 if (ap->PredFlags & LogUpdatePredFlag) {
3452 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(indx_out);
3453 cl->ClFlags |= SwitchRootMask;
3454 }
3455 return(indx_out);
3456 }
3457
3458 static istack_entry *
push_stack(istack_entry * sp,Int arg,Term Tag,Term extra,struct intermediates * cint)3459 push_stack(istack_entry *sp, Int arg, Term Tag, Term extra, struct intermediates *cint)
3460 {
3461 if (sp+1 > (istack_entry *)Yap_TrailTop) {
3462 save_machine_regs();
3463 siglongjmp(cint->CompilerBotch,4);
3464 }
3465 sp->pos = arg;
3466 sp->val = Tag;
3467 sp->extra = extra;
3468 sp++;
3469 sp->pos = 0;
3470 return sp;
3471 }
3472
3473 static istack_entry *
install_clause(ClauseDef * cls,PredEntry * ap,istack_entry * stack)3474 install_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
3475 {
3476 istack_entry *sp = stack;
3477 while (sp->pos) {
3478 if ((Int)(sp->pos) > 0) {
3479 add_info(cls, sp->pos);
3480 } else if (sp->pos) {
3481 UInt argno = -sp->pos;
3482 add_arg_info(cls, ap, argno);
3483 }
3484 /* if we are not talking about a variable */
3485 if (cls->Tag != sp->val) {
3486 if (sp->val == 0L) {
3487 sp++;
3488 }
3489 break;
3490 } else {
3491 if (IsApplTerm(cls->Tag)) {
3492 Functor f = (Functor)RepAppl(cls->Tag);
3493 if (IsExtensionFunctor(f)) {
3494 if (f == FunctorDBRef) {
3495 if (cls->u.t_ptr != sp->extra) break;
3496 } else if (f == FunctorDouble) {
3497 if (cls->u.t_ptr &&
3498 Yap_Double_key(sp->extra) != Yap_Double_key(cls->u.t_ptr))
3499 break;
3500 } else {
3501 if (cls->u.t_ptr &&
3502 Yap_Int_key(sp->extra) != Yap_Int_key(cls->u.t_ptr))
3503 break;
3504 }
3505 }
3506 }
3507 if ((Int)(sp->pos) > 0) {
3508 move_next(cls, sp->pos);
3509 } else if (sp->pos) {
3510 UInt argno = -sp->pos;
3511 skip_to_arg(cls, ap, argno, FALSE);
3512 }
3513 }
3514 sp++;
3515 }
3516 return sp;
3517 }
3518
3519 static ClauseDef *
install_clauses(ClauseDef * cls,PredEntry * ap,istack_entry * stack,yamop * beg,yamop * end)3520 install_clauses(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop *beg, yamop *end)
3521 {
3522 istack_entry *sp = stack;
3523 if (ap->PredFlags & MegaClausePredFlag) {
3524 MegaClause *mcl = ClauseCodeToMegaClause(beg);
3525 yamop *end = (yamop *)((char *)mcl->ClCode+mcl->ClSize);
3526 yamop *cd = mcl->ClCode;
3527
3528 if (stack[0].pos == 0) {
3529 while (TRUE) {
3530 cls->Code = cls->CurrentCode = cd;
3531 cls->Tag = 0;
3532 cls++;
3533 cd = (yamop *)((char *)cd+mcl->ClItemSize);
3534 if (cd == end) {
3535 return cls-1;
3536 }
3537 }
3538 }
3539 while (TRUE) {
3540 cls->Code = cls->CurrentCode = cd;
3541 sp = install_clause(cls, ap, stack);
3542 /* we reached a matching clause */
3543 if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) {
3544 cls++;
3545 }
3546 cd = (yamop *)((char *)cd+mcl->ClItemSize);
3547 if (cd == end) {
3548 return cls-1;
3549 }
3550 }
3551 } else {
3552 StaticClause *cl = ClauseCodeToStaticClause(beg);
3553
3554 if (stack[0].pos == 0) {
3555 while (TRUE) {
3556 cls->Code = cls->CurrentCode = cl->ClCode;
3557 cls->Tag = 0;
3558 cls++;
3559 if (cl->ClCode == end) {
3560 return cls-1;
3561 }
3562 cl = cl->ClNext;
3563 }
3564 }
3565 while (TRUE) {
3566 cls->Code = cls->CurrentCode = cl->ClCode;
3567 sp = install_clause(cls, ap, stack);
3568 /* we reached a matching clause */
3569 if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) {
3570 cls++;
3571 }
3572 if (cl->ClCode == end || cl->ClCode == NULL) {
3573 return cls-1;
3574 }
3575 cl = cl->ClNext;
3576 }
3577 }
3578 }
3579
3580 static ClauseDef *
install_clauseseq(ClauseDef * cls,PredEntry * ap,istack_entry * stack,yamop ** beg,yamop ** end)3581 install_clauseseq(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop **beg, yamop **end)
3582 {
3583 istack_entry *sp = stack;
3584
3585 if (stack[0].pos == 0) {
3586 while (TRUE) {
3587 if (*beg) {
3588 cls->Code = cls->CurrentCode = *beg;
3589 cls->Tag = 0;
3590 cls++;
3591 }
3592 beg++;
3593 if (beg == end) {
3594 return cls-1;
3595 }
3596 }
3597 }
3598 while (TRUE) {
3599 if (*beg) {
3600 cls->Code = cls->CurrentCode = *beg;
3601 sp = install_clause(cls, ap, stack);
3602 /* we reached a matching clause */
3603 if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) {
3604 cls++;
3605 }
3606 }
3607 beg++;
3608 if (beg == end) {
3609 return cls-1;
3610 }
3611 }
3612 }
3613
3614 static void
reinstall_clauses(ClauseDef * cls,ClauseDef * end,PredEntry * ap,istack_entry * stack)3615 reinstall_clauses(ClauseDef *cls, ClauseDef *end, PredEntry *ap, istack_entry *stack)
3616 {
3617 do {
3618 cls->CurrentCode = cls->Code;
3619 install_clause(cls, ap, stack);
3620 } while (cls++ != end);
3621 }
3622
3623 static istack_entry *
install_log_upd_clause(ClauseDef * cls,PredEntry * ap,istack_entry * stack)3624 install_log_upd_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
3625 {
3626 int last_arg = TRUE;
3627
3628 istack_entry *sp = stack;
3629 last_arg = TRUE;
3630 while (sp->pos) {
3631 if ((Int)(sp->pos) > 0) {
3632 add_head_info(cls, sp->pos);
3633 } else if (sp->pos) {
3634 UInt argno = -sp->pos;
3635 add_arg_info(cls, ap, argno);
3636 }
3637 /* if we are not talking about a variable */
3638 if (cls->Tag != sp->val) {
3639 if (sp->val == 0L) {
3640 sp++;
3641 }
3642 break;
3643 } else {
3644 if (IsApplTerm(cls->Tag)) {
3645 Functor f = (Functor)RepAppl(cls->Tag);
3646 if (IsExtensionFunctor(f)) {
3647 if (f == FunctorDBRef) {
3648 if (cls->u.t_ptr != sp->extra) break;
3649 } else if (f == FunctorDouble) {
3650 if (cls->u.t_ptr &&
3651 Yap_Double_key(sp->extra) != Yap_Double_key(cls->u.t_ptr))
3652 break;
3653 } else {
3654 if (cls->u.t_ptr &&
3655 Yap_Int_key(sp->extra) != Yap_Int_key(cls->u.t_ptr))
3656 break;
3657 }
3658 }
3659 }
3660 if ((Int)(sp->pos) > 0) {
3661 move_next(cls, sp->pos);
3662 } else if (sp->pos) {
3663 UInt argno = -sp->pos;
3664 UInt arity;
3665 skip_to_arg(cls, ap, argno, FALSE);
3666 if (IsPairTerm(sp[-1].val))
3667 arity = 2;
3668 else {
3669 Functor f = (Functor)RepAppl(sp[-1].val);
3670 if (IsExtensionFunctor(f))
3671 arity = 0;
3672 else
3673 arity = ArityOfFunctor((Functor)f);
3674 }
3675 if (arity != argno+1) {
3676 last_arg = FALSE;
3677 }
3678 }
3679 }
3680 sp++;
3681 }
3682 return sp;
3683 }
3684
3685 static ClauseDef *
install_log_upd_clauses(ClauseDef * cls,PredEntry * ap,istack_entry * stack,yamop * beg,yamop * end)3686 install_log_upd_clauses(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop *beg, yamop *end)
3687 {
3688 istack_entry *sp = stack;
3689
3690 if (stack[0].pos == 0) {
3691 while (TRUE) {
3692 cls->Code = cls->CurrentCode = beg;
3693 cls->Tag = 0;
3694 cls++;
3695 if (beg == end || beg == NULL) {
3696 return cls-1;
3697 }
3698 beg = ClauseCodeToLogUpdClause(beg)->ClNext->ClCode;
3699 }
3700 }
3701 while (TRUE) {
3702 cls->Code = cls->CurrentCode = beg;
3703 sp = install_log_upd_clause(cls, ap, stack);
3704 /* we reached a matching clause */
3705 if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) {
3706 cls++;
3707 }
3708 if (beg == end || beg == NULL) {
3709 return cls-1;
3710 }
3711 beg = ClauseCodeToLogUpdClause(beg)->ClNext->ClCode;
3712 }
3713 }
3714
3715 static ClauseDef *
install_log_upd_clauseseq(ClauseDef * cls,PredEntry * ap,istack_entry * stack,yamop ** beg,yamop ** end)3716 install_log_upd_clauseseq(ClauseDef *cls, PredEntry *ap, istack_entry *stack, yamop **beg, yamop **end)
3717 {
3718 istack_entry *sp = stack;
3719
3720 if (stack[0].pos == 0) {
3721 while (TRUE) {
3722 if (beg) {
3723 cls->Code = cls->CurrentCode = *beg;
3724 cls->Tag = 0;
3725 cls++;
3726 }
3727 beg++;
3728 if (beg == end) {
3729 return cls-1;
3730 }
3731 }
3732 }
3733 while (TRUE) {
3734 if (*beg) {
3735 cls->Code = cls->CurrentCode = *beg;
3736 sp = install_log_upd_clause(cls, ap, stack);
3737 /* we reached a matching clause */
3738 if (!sp->pos && (sp[-1].val == 0L || cls->Tag == sp[-1].val)) {
3739 cls++;
3740 }
3741 }
3742 beg++;
3743 if (beg == end) {
3744 return cls-1;
3745 }
3746 }
3747 }
3748
3749 static void
reinstall_log_upd_clauses(ClauseDef * cls,ClauseDef * end,PredEntry * ap,istack_entry * stack)3750 reinstall_log_upd_clauses(ClauseDef *cls, ClauseDef *end, PredEntry *ap, istack_entry *stack)
3751 {
3752 do {
3753 cls->CurrentCode = cls->Code;
3754 install_log_upd_clause(cls, ap, stack);
3755 } while (cls++ != end);
3756 }
3757
3758 #if PRECOMPUTE_REGADDRESS
3759
3760 #define arg_from_x(I) (((CELL *)(I))-XREGS)
3761
3762 #else
3763
3764 #define arg_from_x(I) (I)
3765
3766 #endif /* ALIGN_LONGS */
3767
3768 static AtomSwiEntry *
lookup_c(Term t,yamop * tab,COUNT entries)3769 lookup_c(Term t, yamop *tab, COUNT entries)
3770 {
3771 AtomSwiEntry *cebase = (AtomSwiEntry *)tab;
3772
3773 while (cebase->Tag != t) {
3774 entries--;
3775 cebase++;
3776 if (entries == 0)
3777 return cebase;
3778 }
3779 return cebase;
3780 }
3781
3782 static FuncSwiEntry *
lookup_f(Functor f,yamop * tab,COUNT entries)3783 lookup_f(Functor f, yamop *tab, COUNT entries)
3784 {
3785 FuncSwiEntry *febase = (FuncSwiEntry *)tab;
3786
3787 while (febase->Tag != f) {
3788 entries--;
3789 febase++;
3790 if (entries == 0)
3791 return febase;
3792 }
3793 return febase;
3794 }
3795
3796 static COUNT
count_clauses_left(yamop * cl,PredEntry * ap)3797 count_clauses_left(yamop *cl, PredEntry *ap)
3798 {
3799 if (ap->PredFlags & LogUpdatePredFlag) {
3800 LogUpdClause *c = ClauseCodeToLogUpdClause(cl);
3801 COUNT i = 0;
3802
3803 while (c != NULL) {
3804 i++;
3805 c = c->ClNext;
3806 }
3807 return i;
3808 } else if (ap->PredFlags & MegaClausePredFlag) {
3809 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
3810 UInt ncls = mcl->ClSize/mcl->ClItemSize;
3811
3812 return (ncls-1)-((char *)cl-(char *)mcl->ClCode)/mcl->ClItemSize;
3813 } else {
3814 yamop *last = ap->cs.p_code.LastClause;
3815 StaticClause *c;
3816 COUNT i = 1;
3817
3818 c = ClauseCodeToStaticClause(cl);
3819 while (c->ClCode != last) {
3820 i++;
3821 c = c->ClNext;
3822 }
3823 return i;
3824 }
3825 }
3826
3827 /*
3828 We have jumped across indexing code. Check if we jumped within the current
3829 indexing block, if we moved back to a parent, or if we jumped to a child.
3830 */
3831 static ClausePointer
index_jmp(ClausePointer cur,ClausePointer parent,yamop * ipc,int is_lu,yamop * e_code)3832 index_jmp(ClausePointer cur, ClausePointer parent, yamop *ipc, int is_lu, yamop *e_code)
3833 {
3834 if (cur.lui == NULL ||
3835 ipc == FAILCODE ||
3836 ipc == e_code ||
3837 ipc->opc == Yap_opcode(_expand_clauses)
3838 )
3839 return cur;
3840 if (is_lu) {
3841 LogUpdIndex *lcur = cur.lui, *ncur;
3842 /* check myself */
3843 if (ipc >= lcur->ClCode && ipc < (yamop *)((CODEADDR)lcur+lcur->ClSize))
3844 return cur;
3845 /* check if I am returning back to a parent, eg
3846 switch with intermediate node */
3847 if (lcur->ParentIndex) {
3848 LogUpdIndex *pcur = lcur->ParentIndex;
3849 if (ipc >= pcur->ClCode && ipc < (yamop *)((CODEADDR)pcur+pcur->ClSize)) {
3850 cur.lui = pcur;
3851 return cur;
3852 }
3853 }
3854 /* maybe I am a new group */
3855 ncur = ClauseCodeToLogUpdIndex(ipc);
3856 if (ncur->ParentIndex != lcur) {
3857 #ifdef DEBUG
3858 fprintf(stderr,"OOPS, bad parent in lu index\n");
3859 #endif
3860 cur.lui = NULL;
3861 return cur;
3862 }
3863 cur.lui = ncur;
3864 return cur;
3865 } else {
3866 StaticIndex *scur = parent.si, *ncur;
3867 /* check myself */
3868 if (!scur)
3869 return cur;
3870 if (ipc >= scur->ClCode &&
3871 ipc < (yamop *)((CODEADDR)scur+scur->ClSize))
3872 return cur;
3873 ncur = ClauseCodeToStaticIndex(ipc);
3874 if (ncur->ClPred == scur->ClPred) {
3875 cur.si = ncur;
3876 return cur;
3877 }
3878 /*
3879 if (parent.si != cur.si) {
3880 if (parent.si) {
3881 StaticIndex *pcur = parent.si;
3882 if (ipc >= pcur->ClCode && ipc < (yamop *)((CODEADDR)pcur+pcur->ClSize))
3883 return parent;
3884 }
3885 }
3886 cur.si = ncur;
3887 return cur;
3888 */
3889 cur.si = NULL;
3890 return cur;
3891 }
3892 }
3893
3894 static ClausePointer
code_to_indexcl(yamop * ipc,int is_lu)3895 code_to_indexcl(yamop *ipc, int is_lu)
3896 {
3897 ClausePointer ret;
3898 if (is_lu)
3899 ret.lui = ClauseCodeToLogUpdIndex(ipc);
3900 else
3901 ret.si = ClauseCodeToStaticIndex(ipc);
3902 return ret;
3903 }
3904
3905 static yamop **
expand_index(struct intermediates * cint)3906 expand_index(struct intermediates *cint) {
3907 /* first clause */
3908 PredEntry *ap = cint->CurrentPred;
3909 yamop *first, *last = NULL, *alt = NULL;
3910 istack_entry *stack, *sp;
3911 ClauseDef *max;
3912 int NClauses;
3913 /* last clause to experiment with */
3914 yamop *ipc;
3915 /* labp should point at the beginning of the sequence */
3916 yamop **labp = NULL;
3917 ClausePointer parentcl;
3918 Term t = TermNil, *s_reg = NULL;
3919 int is_last_arg = TRUE;
3920 int argno = 1;
3921 int isfirstcl = TRUE;
3922 /* this is will be used as a new PC */
3923 CELL *top = (CELL *) TR;
3924 UInt arity = 0;
3925 UInt lab, fail_l, clleft, i = 0;
3926 int is_lu = ap->PredFlags & LogUpdatePredFlag;
3927 yamop *eblk = NULL;
3928 yamop *e_code = (yamop *)&(ap->cs.p_code.ExpandCode);
3929
3930 ipc = ap->cs.p_code.TrueCodeOfPred;
3931 first = ap->cs.p_code.FirstClause;
3932 NClauses = ap->cs.p_code.NOfClauses;
3933 sp = stack = (istack_entry *)top;
3934 cint->i_labelno = 1;
3935 stack[0].pos = 0;
3936 /* try to refine the interval using the indexing code */
3937
3938 parentcl = code_to_indexcl(ipc,is_lu);
3939 while (ipc != NULL) {
3940 op_numbers op;
3941
3942 op = Yap_op_from_opcode(ipc->opc);
3943 switch(op) {
3944 case _try_clause:
3945 case _retry:
3946 /* this clause had no indexing */
3947 if (ap->PredFlags & LogUpdatePredFlag) {
3948 first = ClauseCodeToLogUpdClause(ipc->u.Otapl.d)->ClNext->ClCode;
3949 } else if (ap->PredFlags & MegaClausePredFlag) {
3950 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
3951 first = (yamop *)((char *)ipc->u.Otapl.d)+mcl->ClItemSize;
3952 } else {
3953 first = ClauseCodeToStaticClause(ipc->u.Otapl.d)->ClNext->ClCode;
3954 }
3955 isfirstcl = FALSE;
3956 ipc = NEXTOP(ipc,Otapl);
3957 break;
3958 #if TABLING
3959 case _table_try:
3960 case _table_retry:
3961 /* this clause had no indexing */
3962 first = ClauseCodeToStaticClause(PREVOP(ipc->u.Otapl.d,Otapl))->ClNext->ClCode;
3963 isfirstcl = FALSE;
3964 ipc = NEXTOP(ipc,Otapl);
3965 break;
3966 #endif /* TABLING */
3967 case _try_clause2:
3968 case _try_clause3:
3969 case _try_clause4:
3970 case _retry2:
3971 case _retry3:
3972 case _retry4:
3973 case _try_in:
3974 if (ap->PredFlags & LogUpdatePredFlag) {
3975 first = ClauseCodeToLogUpdClause(ipc->u.l.l)->ClNext->ClCode;
3976 } else if (ap->PredFlags & MegaClausePredFlag) {
3977 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
3978 first = (yamop *)((char *)ipc->u.Otapl.d)+mcl->ClItemSize;
3979 } else {
3980 first = ClauseCodeToStaticClause(ipc->u.l.l)->ClNext->ClCode;
3981 }
3982 isfirstcl = FALSE;
3983 ipc = NEXTOP(ipc,l);
3984 break;
3985 case _retry_me:
3986 #ifdef TABLING
3987 case _table_retry_me:
3988 #endif
3989 isfirstcl = FALSE;
3990 case _try_me:
3991 #ifdef TABLING
3992 case _table_try_me:
3993 #endif
3994 /* ok, we found the start for an indexing block,
3995 but we don't if we are going to operate here or not */
3996 /* if we are to commit here, alt will tell us where */
3997 alt = ipc->u.Otapl.d;
3998 ipc = NEXTOP(ipc,Otapl);
3999 /* start of a group, reset stack */
4000 sp = stack;
4001 stack[0].pos = 0;
4002 break;
4003 case _profiled_trust_me:
4004 case _trust_me:
4005 case _count_trust_me:
4006 #ifdef TABLING
4007 case _table_trust_me:
4008 #endif /* TABLING */
4009 /* we will commit to this group for sure */
4010 ipc = NEXTOP(ipc,Otapl);
4011 alt = NULL;
4012 /* start of a group, reset stack */
4013 sp = stack;
4014 stack[0].pos = 0;
4015 break;
4016 case _trust:
4017 /* we should never be here */
4018 Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "found trust in expand_index");
4019 labp = NULL;
4020 ipc = NULL;
4021 break;
4022 /* should we ever be here ? I think not */
4023 case _try_logical:
4024 case _retry_logical:
4025 case _count_retry_logical:
4026 case _profiled_retry_logical:
4027 ipc = ipc->u.OtaLl.n;
4028 break;
4029 case _trust_logical:
4030 case _count_trust_logical:
4031 case _profiled_trust_logical:
4032 ipc = ipc->u.OtILl.n;
4033 break;
4034 case _enter_lu_pred:
4035 /* no useful info */
4036 ipc = ipc->u.Ills.l1;
4037 break;
4038 case _retry_profiled:
4039 case _count_retry:
4040 /* no useful info */
4041 ipc = NEXTOP(ipc,l);
4042 break;
4043 case _jump:
4044 /* just skip for now, but should worry about memory management */
4045 ipc = ipc->u.l.l;
4046 /* I don't know how up I will go */
4047 parentcl.si = NULL;
4048 break;
4049 case _lock_lu:
4050 case _procceed:
4051 ipc = NEXTOP(ipc,p);
4052 break;
4053 case _unlock_lu:
4054 ipc = NEXTOP(ipc,e);
4055 break;
4056 case _jump_if_var:
4057 if (IsVarTerm(Deref(ARG1))) {
4058 labp = &(ipc->u.l.l);
4059 ipc = ipc->u.l.l;
4060 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4061 } else {
4062 ipc = NEXTOP(ipc,l);
4063 }
4064 break;
4065 case _jump_if_nonvar:
4066 argno = arg_from_x(ipc->u.xll.x);
4067 t = Deref(XREGS[argno]);
4068 i = 0;
4069 /* expand_index expects to find the new argument */
4070 if (!IsVarTerm(t)) {
4071 argno--;
4072 labp = &(ipc->u.xll.l1);
4073 ipc = ipc->u.xll.l1;
4074 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4075 } else {
4076 ipc = NEXTOP(ipc,xll);
4077 }
4078 break;
4079 /* instructions type EC */
4080 /* instructions type e */
4081 case _index_dbref:
4082 t = AbsAppl(s_reg-1);
4083 sp[-1].extra = t;
4084 s_reg = NULL;
4085 ipc = NEXTOP(ipc,e);
4086 break;
4087 case _index_blob:
4088 t = Yap_DoubleP_key(s_reg);
4089 sp[-1].extra = AbsAppl(s_reg-1);
4090 s_reg = NULL;
4091 ipc = NEXTOP(ipc,e);
4092 break;
4093 case _index_long:
4094 t = Yap_IntP_key(s_reg);
4095 sp[-1].extra = AbsAppl(s_reg-1);
4096 s_reg = NULL;
4097 ipc = NEXTOP(ipc,e);
4098 break;
4099 case _user_switch:
4100 labp = &(ipc->u.lp.l);
4101 ipc = ipc->u.lp.l;
4102 break;
4103 /* instructions type e */
4104 case _switch_on_type:
4105 t = Deref(ARG1);
4106 argno = 1;
4107 i = 0;
4108 if (IsVarTerm(t)) {
4109 labp = &(ipc->u.llll.l4);
4110 ipc = ipc->u.llll.l4;
4111 } else if (IsPairTerm(t)) {
4112 sp = push_stack(sp, 1, AbsPair(NULL), TermNil, cint);
4113 s_reg = RepPair(t);
4114 labp = &(ipc->u.llll.l1);
4115 ipc = ipc->u.llll.l1;
4116 } else if (IsApplTerm(t)) {
4117 sp = push_stack(sp, 1, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint);
4118 ipc = ipc->u.llll.l3;
4119 } else {
4120 sp = push_stack(sp, argno, t, TermNil, cint);
4121 ipc = ipc->u.llll.l2;
4122 }
4123 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4124 break;
4125 case _switch_list_nl:
4126 t = Deref(ARG1);
4127 argno = 1;
4128 i = 0;
4129 if (IsVarTerm(t)) {
4130 labp = &(ipc->u.ollll.l4);
4131 ipc = ipc->u.ollll.l4;
4132 } else if (IsPairTerm(t)) {
4133 s_reg = RepPair(t);
4134 labp = &(ipc->u.ollll.l1);
4135 sp = push_stack(sp, 1, AbsPair(NULL), TermNil, cint);
4136 ipc = ipc->u.ollll.l1;
4137 } else if (t == TermNil) {
4138 sp = push_stack(sp, 1, t, TermNil, cint);
4139 ipc = ipc->u.ollll.l2;
4140 } else {
4141 Term tn;
4142
4143 if (IsApplTerm(t)) {
4144 tn = AbsAppl((CELL *)FunctorOfTerm(t));
4145 } else {
4146 tn = t;
4147 }
4148 sp = push_stack(sp, argno, tn, TermNil, cint);
4149 ipc = ipc->u.ollll.l3;
4150 }
4151 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4152 break;
4153 case _switch_on_arg_type:
4154 argno = arg_from_x(ipc->u.xllll.x);
4155 i = 0;
4156 t = Deref(XREGS[argno]);
4157 if (IsVarTerm(t)) {
4158 labp = &(ipc->u.xllll.l4);
4159 ipc = ipc->u.xllll.l4;
4160 } else if (IsPairTerm(t)) {
4161 s_reg = RepPair(t);
4162 sp = push_stack(sp, argno, AbsPair(NULL), TermNil, cint);
4163 labp = &(ipc->u.xllll.l1);
4164 ipc = ipc->u.xllll.l1;
4165 } else if (IsApplTerm(t)) {
4166 sp = push_stack(sp, argno, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint);
4167 ipc = ipc->u.xllll.l3;
4168 } else {
4169 sp = push_stack(sp, argno, t, TermNil, cint);
4170 ipc = ipc->u.xllll.l2;
4171 }
4172 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4173 break;
4174 case _switch_on_sub_arg_type:
4175 i = ipc->u.sllll.s;
4176 t = Deref(s_reg[i]);
4177 if (i != arity-1) is_last_arg = FALSE;
4178 t = Deref(s_reg[i]);
4179 if (IsVarTerm(t)) {
4180 labp = &(ipc->u.sllll.l4);
4181 ipc = ipc->u.sllll.l4;
4182 i++;
4183 } else if (IsPairTerm(t)) {
4184 s_reg = RepPair(t);
4185 sp = push_stack(sp, -i-1, AbsPair(NULL), TermNil, cint);
4186 labp = &(ipc->u.sllll.l1);
4187 ipc = ipc->u.sllll.l1;
4188 i = 0;
4189 } else if (IsApplTerm(t)) {
4190 sp = push_stack(sp, -i-1, AbsAppl((CELL *)FunctorOfTerm(t)), TermNil, cint);
4191 ipc = ipc->u.sllll.l3;
4192 i = 0;
4193 } else {
4194 /* We don't push stack here, instead we go over to next argument
4195 sp = push_stack(sp, -i-1, t, cint);
4196 */
4197 sp = push_stack(sp, -i-1, t, TermNil, cint);
4198 ipc = ipc->u.sllll.l2;
4199 i++;
4200 }
4201 parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
4202 break;
4203 case _if_not_then:
4204 labp = NULL;
4205 ipc = NULL;
4206 break;
4207 /* instructions type ollll */
4208 case _switch_on_func:
4209 case _if_func:
4210 case _go_on_func:
4211 {
4212 FuncSwiEntry *fe;
4213 yamop *newpc;
4214 Functor f;
4215
4216 s_reg = RepAppl(t);
4217 f = (Functor)(*s_reg++);
4218 if (op == _switch_on_func) {
4219 fe = lookup_f_hash(f,ipc->u.sssl.l,ipc->u.sssl.s);
4220 } else {
4221 fe = lookup_f(f,ipc->u.sssl.l,ipc->u.sssl.s);
4222 }
4223 newpc = fe->u.labp;
4224
4225 labp = &(fe->u.labp);
4226 if (newpc == e_code) {
4227 /* we found it */
4228 parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu);
4229 ipc = NULL;
4230 } else {
4231 ClausePointer npar = code_to_indexcl(ipc->u.sssl.l,is_lu);
4232 ipc = newpc;
4233 parentcl = index_jmp(npar, parentcl, ipc, is_lu, e_code);
4234 }
4235 }
4236 break;
4237 case _switch_on_cons:
4238 case _if_cons:
4239 case _go_on_cons:
4240 {
4241 AtomSwiEntry *ae;
4242
4243 if (op == _switch_on_cons) {
4244 ae = lookup_c_hash(t,ipc->u.sssl.l,ipc->u.sssl.s);
4245 } else {
4246 ae = lookup_c(t,ipc->u.sssl.l,ipc->u.sssl.s);
4247 }
4248
4249 labp = &(ae->u.labp);
4250 if (ae->u.labp == e_code) {
4251 /* we found it */
4252 parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu);
4253 ipc = NULL;
4254 } else {
4255 ClausePointer npar = code_to_indexcl(ipc->u.sssl.l,is_lu);
4256 ipc = ae->u.labp;
4257 parentcl = index_jmp(npar, parentcl, ipc, is_lu, e_code);
4258 }
4259 }
4260 break;
4261 case _expand_index:
4262 case _expand_clauses:
4263 if (alt != NULL && ap->PredFlags & LogUpdatePredFlag) {
4264 op_numbers fop = Yap_op_from_opcode(alt->opc);
4265 if (fop == _enter_lu_pred)
4266 alt = alt->u.Ills.l1;
4267 }
4268 ipc = NULL;
4269 break;
4270 case _op_fail:
4271 ipc = alt;
4272 alt = NULL;
4273 break;
4274 default:
4275 if (alt == NULL) {
4276 Yap_Error(INTERNAL_COMPILER_ERROR,t,"unexpected instruction %d at expand_index ", op);
4277 labp = NULL;
4278 ipc = NULL;
4279 } else {
4280 /* backtrack */
4281 first = alt->u.Otapl.d;
4282 ipc = alt;
4283 alt = NULL;
4284 }
4285 }
4286 }
4287
4288 /* if there was an overflow while generating the code, make sure
4289 S is still correct */
4290 if (is_lu) {
4291 cint->current_cl.lui = parentcl.lui;
4292 } else {
4293 cint->current_cl.si = parentcl.si;
4294 }
4295 if (s_reg != NULL)
4296 S = s_reg;
4297 #ifdef TABLING
4298 /* handle tabling hack that insertes a failcode,
4299 this really corresponds to not having any more clauses */
4300 if (alt == TRUSTFAILCODE)
4301 alt = NULL;
4302 #endif
4303 if (alt == NULL) {
4304 /* oops, we are at last clause */
4305 fail_l = (UInt)FAILCODE;
4306 clleft = 0;
4307 last = ap->cs.p_code.LastClause;
4308 } else {
4309 if (ap->PredFlags & LogUpdatePredFlag) {
4310 op_numbers op = Yap_op_from_opcode(alt->opc);
4311 /* can we be here */
4312 if (op >= _retry2 && op <= _retry4) {
4313 last = alt->u.l.l;
4314 } else {
4315 last = alt->u.Otapl.d;
4316 }
4317 } else {
4318 op_numbers op = Yap_op_from_opcode(alt->opc);
4319 if (op == _retry || op == _trust) {
4320 last = alt->u.Otapl.d;
4321 #ifdef TABLING
4322 } else if (op == _table_retry || op == _table_trust) {
4323 last = PREVOP(alt->u.Otapl.d,Otapl);
4324 #endif /* TABLING */
4325 } else if (op >= _retry2 && op <= _retry4) {
4326 last = alt->u.l.l;
4327 }
4328 }
4329 fail_l = (UInt)alt;
4330 clleft = count_clauses_left(last,ap);
4331 }
4332
4333 if (Yap_op_from_opcode((*labp)->opc) == _expand_clauses) {
4334 /* ok, we know how many clauses */
4335 yamop *ipc = *labp;
4336 /* check all slots, not just the ones with values */
4337 COUNT nclauses = ipc->u.sssllp.s1;
4338 yamop **clp = (yamop **)NEXTOP(ipc,sssllp);
4339
4340 eblk = cint->expand_block = ipc;
4341 #if USE_SYSTEM_MALLOC
4342 if (!cint->cls) {
4343 cint->cls = (ClauseDef *)Yap_AllocCodeSpace(nclauses*sizeof(ClauseDef));
4344 if (!cint->cls) {
4345 /* tell how much space we need */
4346 Yap_Error_Size += NClauses*sizeof(ClauseDef);
4347 /* grow stack */
4348 save_machine_regs();
4349 siglongjmp(cint->CompilerBotch,2);
4350 }
4351 }
4352 #else
4353 cint->cls = (ClauseDef *)H;
4354 if (cint->cls+2*nclauses > (ClauseDef *)(ASP-4096)) {
4355 /* tell how much space we need (worst case) */
4356 Yap_Error_Size += 2*NClauses*sizeof(ClauseDef);
4357 /* grow stack */
4358 save_machine_regs();
4359 siglongjmp(cint->CompilerBotch,3);
4360 }
4361 #endif
4362 if (ap->PredFlags & LogUpdatePredFlag) {
4363 max = install_log_upd_clauseseq(cint->cls, ap, stack, clp, clp+nclauses);
4364 } else {
4365 max = install_clauseseq(cint->cls, ap, stack, clp, clp+nclauses);
4366 }
4367 } else {
4368 cint->expand_block = NULL;
4369 #if USE_SYSTEM_MALLOC
4370 if (!cint->cls) {
4371 cint->cls = (ClauseDef *)Yap_AllocCodeSpace(NClauses*sizeof(ClauseDef));
4372 if (!cint->cls) {
4373 /* tell how much space we need */
4374 Yap_Error_Size += NClauses*sizeof(ClauseDef);
4375 /* grow stack */
4376 save_machine_regs();
4377 siglongjmp(cint->CompilerBotch,2);
4378 }
4379 }
4380 #else
4381 cint->cls = (ClauseDef *)H;
4382 if (cint->cls+2*NClauses > (ClauseDef *)(ASP-4096)) {
4383 /* tell how much space we need (worst case) */
4384 Yap_Error_Size += 2*NClauses*sizeof(ClauseDef);
4385 save_machine_regs();
4386 siglongjmp(cint->CompilerBotch,3);
4387 }
4388 #endif
4389 if (ap->PredFlags & LogUpdatePredFlag) {
4390 max = install_log_upd_clauses(cint->cls, ap, stack, first, last);
4391 } else {
4392 max = install_clauses(cint->cls, ap, stack, first, last);
4393 }
4394 #if DEBUG_EXPAND
4395 if (ap->PredFlags & LogUpdatePredFlag) {
4396 fprintf(stderr,"vsc +");
4397 } else {
4398 fprintf(stderr,"vsc ");
4399 }
4400 fprintf(stderr," : expanding %d out of %d\n", (max-cls)+1,NClauses);
4401 #endif
4402 }
4403 /* don't count last clause if you don't have to */
4404 if (alt && max->Code == last) max--;
4405 if (max < cint->cls && labp != NULL) {
4406 *labp = FAILCODE;
4407 return labp;
4408 }
4409 #if USE_SYSTEM_MALLOC
4410 cint->freep = (char *)H;
4411 #else
4412 cint->freep = (char *)(max+1);
4413 #endif
4414 cint->CodeStart = cint->BlobsStart = cint->cpc = cint->icpc = NULL;
4415
4416 if (!IsVarTerm(sp[-1].val) && sp > stack) {
4417 if (IsAtomOrIntTerm(sp[-1].val)) {
4418 if (s_reg == NULL) { /* we have not yet looked into terms */
4419 lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top);
4420 } else {
4421 UInt arity = 0;
4422
4423 if (ap->PredFlags & LogUpdatePredFlag) {
4424 reinstall_log_upd_clauses(cint->cls, max, ap, stack);
4425 } else {
4426 reinstall_clauses(cint->cls, max, ap, stack);
4427 }
4428 sp--;
4429 while (sp > stack) {
4430 Term t = sp[-1].val;
4431 if (IsApplTerm(t)) {
4432 Functor f = (Functor)RepAppl(t);
4433 if (!IsExtensionFunctor(f)) {
4434 arity = ArityOfFunctor(f);
4435 break;
4436 } else {
4437 sp--;
4438 }
4439 } else if (IsPairTerm(t)) {
4440 arity = 2;
4441 break;
4442 } else {
4443 sp--;
4444 }
4445 }
4446 lab = do_compound_index(cint->cls, max, s_reg, cint, i, arity, argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE);
4447 }
4448 } else if (IsPairTerm(sp[-1].val) && sp > stack) {
4449 lab = do_compound_index(cint->cls, max, s_reg, cint, i, 2, argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE);
4450 } else {
4451 Functor f = (Functor)RepAppl(sp[-1].val);
4452 /* we are continuing within a compound term */
4453 if (IsExtensionFunctor(f)) {
4454 lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top);
4455 } else {
4456 lab = do_compound_index(cint->cls, max, s_reg, cint, i, ArityOfFunctor(f), argno, fail_l, isfirstcl, is_last_arg, clleft, top, FALSE);
4457 }
4458 }
4459 } else {
4460 if (argno == ap->ArityOfPE) {
4461 lab =
4462 do_var_clauses(cint->cls, max, FALSE, cint, isfirstcl, clleft, fail_l, ap->ArityOfPE+1);
4463 } else {
4464 lab = do_index(cint->cls, max, cint, argno+1, fail_l, isfirstcl, clleft, top);
4465 }
4466 }
4467 if (labp && !(lab & 1)) {
4468 *labp = (yamop *)lab; /* in case we have a single clause */
4469 }
4470 return labp;
4471 }
4472
4473
4474 static yamop *
ExpandIndex(PredEntry * ap,int ExtraArgs,yamop * nextop)4475 ExpandIndex(PredEntry *ap, int ExtraArgs, yamop *nextop) {
4476 yamop *indx_out, *expand_clauses;
4477 yamop **labp;
4478 int cb;
4479 struct intermediates cint;
4480
4481 cint.blks = NULL;
4482 cint.cls = NULL;
4483 cint.code_addr = NULL;
4484 cint.label_offset = NULL;
4485 if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) {
4486 restore_machine_regs();
4487 /* grow stack */
4488 recover_from_failed_susp_on_cls(&cint, 0);
4489 Yap_gcl(Yap_Error_Size, ap->ArityOfPE+ExtraArgs, ENV, nextop);
4490 } else if (cb == 2) {
4491 restore_machine_regs();
4492 Yap_Error_Size = recover_from_failed_susp_on_cls(&cint, Yap_Error_Size);
4493 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
4494 save_machine_regs();
4495 if (ap->PredFlags & LogUpdatePredFlag) {
4496 Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap);
4497 } else {
4498 StaticIndex *cl;
4499
4500 cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
4501 Yap_kill_iblock((ClauseUnion *)ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap);
4502 }
4503 #if defined(YAPOR) || defined(THREADS)
4504 if (ap->PredFlags & LogUpdatePredFlag &&
4505 ap->ModuleOfPred != IDB_MODULE) {
4506 ap->OpcodeOfPred = LOCKPRED_OPCODE;
4507 ap->cs.p_code.TrueCodeOfPred = ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
4508 } else {
4509 #endif
4510 ap->OpcodeOfPred = INDEX_OPCODE;
4511 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
4512 #if defined(YAPOR) || defined(THREADS)
4513 }
4514 #endif
4515 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
4516 CleanCls(&cint);
4517 return FAILCODE;
4518 }
4519 } else if (cb == 4) {
4520 restore_machine_regs();
4521 Yap_ReleaseCMem(&cint);
4522 if (!Yap_growtrail(Yap_Error_Size, FALSE)) {
4523 save_machine_regs();
4524 if (ap->PredFlags & LogUpdatePredFlag) {
4525 Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap);
4526 } else {
4527 StaticIndex *cl;
4528
4529 cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
4530 Yap_kill_iblock((ClauseUnion *)cl, NULL, ap);
4531 }
4532 CleanCls(&cint);
4533 return FAILCODE;
4534 }
4535 }
4536 restart_index:
4537 cint.CodeStart = cint.cpc = cint.BlobsStart = cint.icpc = NIL;
4538 cint.CurrentPred = ap;
4539 Yap_ErrorMessage = NULL;
4540 Yap_Error_Size = 0;
4541 if (P->opc == Yap_opcode(_expand_clauses)) {
4542 expand_clauses = P;
4543 } else {
4544 expand_clauses = NULL;
4545 }
4546 #ifdef DEBUG
4547 if (Yap_Option['i' - 'a' + 1]) {
4548 Term tmod = ap->ModuleOfPred;
4549 Yap_LockStream(Yap_c_error_stream);
4550 if (!tmod) tmod = TermProlog;
4551 #if THREADS
4552 Yap_DebugPlWrite(MkIntegerTerm(worker_id));
4553 Yap_DebugPutc(Yap_c_error_stream,' ');
4554 #endif
4555 Yap_DebugPutc(Yap_c_error_stream,'>');
4556 Yap_DebugPutc(Yap_c_error_stream,'\t');
4557 Yap_DebugPlWrite(tmod);
4558 Yap_DebugPutc(Yap_c_error_stream,':');
4559 if (ap->ModuleOfPred == IDB_MODULE) {
4560 Term t = Deref(ARG1);
4561 if (IsAtomTerm(t)) {
4562 Yap_DebugPlWrite(t);
4563 } else if (IsIntegerTerm(t)) {
4564 Yap_DebugPlWrite(t);
4565 } else {
4566 Functor f = FunctorOfTerm(t);
4567 Atom At = NameOfFunctor(f);
4568 Yap_DebugPlWrite(MkAtomTerm(At));
4569 Yap_DebugPutc(Yap_c_error_stream,'/');
4570 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
4571 }
4572 } else {
4573 if (ap->ArityOfPE == 0) {
4574 Atom At = (Atom)ap->FunctorOfPred;
4575 Yap_DebugPlWrite(MkAtomTerm(At));
4576 } else {
4577 Functor f = ap->FunctorOfPred;
4578 Atom At = NameOfFunctor(f);
4579 Yap_DebugPlWrite(MkAtomTerm(At));
4580 Yap_DebugPutc(Yap_c_error_stream,'/');
4581 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
4582 }
4583 Yap_UnLockStream(Yap_c_error_stream);
4584 }
4585 Yap_DebugPutc(Yap_c_error_stream,'\n');
4586 #if THREADS
4587 Yap_DebugPlWrite(MkIntegerTerm(worker_id));
4588 Yap_DebugPutc(Yap_c_error_stream,' ');
4589 #endif
4590 Yap_UnLockStream(Yap_c_error_stream);
4591 }
4592 #endif
4593 if ((labp = expand_index(&cint)) == NULL) {
4594 if (expand_clauses) {
4595 P = FAILCODE;
4596 recover_ecls_block(expand_clauses);
4597 }
4598 Yap_ReleaseCMem(&cint);
4599 CleanCls(&cint);
4600 return FAILCODE;
4601 }
4602 if (*labp == FAILCODE) {
4603 if (expand_clauses) {
4604 P = FAILCODE;
4605 recover_ecls_block(expand_clauses);
4606 }
4607 Yap_ReleaseCMem(&cint);
4608 CleanCls(&cint);
4609 return FAILCODE;
4610 }
4611 #ifdef DEBUG
4612 if (Yap_Option['i' - 'a' + 1]) {
4613 Yap_LockStream(Yap_c_error_stream);
4614 Yap_ShowCode(&cint);
4615 Yap_UnLockStream(Yap_c_error_stream);
4616 }
4617 #endif
4618 /* globals for assembler */
4619 IPredArity = ap->ArityOfPE;
4620 if (cint.CodeStart) {
4621 if ((indx_out = Yap_assemble(ASSEMBLING_EINDEX, TermNil, ap, FALSE, &cint, cint.i_labelno+1)) == NULL) {
4622 if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
4623 Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
4624 Yap_ReleaseCMem(&cint);
4625 CleanCls(&cint);
4626 return FAILCODE;
4627 }
4628 goto restart_index;
4629 }
4630 } else {
4631 /* single case */
4632 if (expand_clauses) {
4633 P = *labp;
4634 recover_ecls_block(expand_clauses);
4635 }
4636 Yap_ReleaseCMem(&cint);
4637 CleanCls(&cint);
4638 return *labp;
4639 }
4640 if (indx_out == NULL) {
4641 if (expand_clauses) {
4642 P = FAILCODE;
4643 recover_ecls_block(expand_clauses);
4644 }
4645 Yap_ReleaseCMem(&cint);
4646 CleanCls(&cint);
4647 return FAILCODE;
4648 }
4649 Yap_ReleaseCMem(&cint);
4650 CleanCls(&cint);
4651 *labp = indx_out;
4652 if (ap->PredFlags & LogUpdatePredFlag) {
4653 /* add to head of current code children */
4654 LogUpdIndex *ic = cint.current_cl.lui,
4655 *nic = ClauseCodeToLogUpdIndex(indx_out);
4656 if (ic == NULL)
4657 ic = (LogUpdIndex *)Yap_find_owner_index((yamop *)labp, ap);
4658 /* insert myself in the indexing code chain */
4659 nic->SiblingIndex = ic->ChildIndex;
4660 nic->PrevSiblingIndex = NULL;
4661 if (ic->ChildIndex) {
4662 ic->ChildIndex->PrevSiblingIndex = nic;
4663 }
4664 nic->ParentIndex = ic;
4665 nic->ClFlags &= ~SwitchRootMask;
4666 ic->ChildIndex = nic;
4667 ic->ClRefCount++;
4668 } else {
4669 /* add to head of current code children */
4670 StaticIndex *ic = cint.current_cl.si,
4671 *nic = ClauseCodeToStaticIndex(indx_out);
4672 if (ic == NULL)
4673 ic = (StaticIndex *)Yap_find_owner_index((yamop *)labp, ap);
4674 /* insert myself in the indexing code chain */
4675 nic->SiblingIndex = ic->ChildIndex;
4676 ic->ChildIndex = nic;
4677 }
4678 if (expand_clauses) {
4679 P = indx_out;
4680 recover_ecls_block(expand_clauses);
4681 }
4682 return indx_out;
4683 }
4684
4685 yamop *
Yap_ExpandIndex(PredEntry * ap,UInt nargs)4686 Yap_ExpandIndex(PredEntry *ap, UInt nargs) {
4687 return ExpandIndex(ap, nargs, CP);
4688 }
4689
4690 static path_stack_entry *
push_path(path_stack_entry * sp,yamop ** pipc,ClauseDef * clp,struct intermediates * cint)4691 push_path(path_stack_entry *sp, yamop **pipc, ClauseDef *clp, struct intermediates *cint)
4692 {
4693 if (sp+1 > (path_stack_entry *)Yap_TrailTop) {
4694 save_machine_regs();
4695 siglongjmp(cint->CompilerBotch,4);
4696 }
4697 sp->flag = pc_entry;
4698 sp->u.pce.pi_pc = pipc;
4699 sp->u.pce.code = clp->Code;
4700 sp->u.pce.current_code = clp->CurrentCode;
4701 sp->u.pce.work_pc = clp->u.WorkPC;
4702 sp->u.pce.tag = clp->Tag;
4703 return sp+1;
4704 }
4705
4706 static path_stack_entry *
fetch_new_block(path_stack_entry * sp,yamop ** pipc,PredEntry * ap,struct intermediates * cint)4707 fetch_new_block(path_stack_entry *sp, yamop **pipc, PredEntry *ap, struct intermediates *cint)
4708 {
4709 if (sp+1 > (path_stack_entry *)Yap_TrailTop) {
4710 save_machine_regs();
4711 siglongjmp(cint->CompilerBotch,4);
4712 }
4713 /* add current position */
4714 sp->flag = block_entry;
4715 sp->u.cle.entry_code = pipc;
4716 if (ap->PredFlags & LogUpdatePredFlag) {
4717 sp->u.cle.block = (ClauseUnion *)ClauseCodeToLogUpdIndex(*pipc);
4718 } else {
4719 sp->u.cle.block = (ClauseUnion *)ClauseCodeToStaticIndex(*pipc);
4720 }
4721 return sp+1;
4722 }
4723
4724 static path_stack_entry *
init_block_stack(path_stack_entry * sp,yamop * ipc,PredEntry * ap)4725 init_block_stack(path_stack_entry *sp, yamop *ipc, PredEntry *ap)
4726 {
4727 /* add current position */
4728
4729 sp->flag = block_entry;
4730 sp->u.cle.entry_code = NULL;
4731 if (ap->PredFlags & LogUpdatePredFlag) {
4732 sp->u.cle.block = (ClauseUnion *)ClauseCodeToLogUpdIndex(ipc);
4733 } else {
4734 sp->u.cle.block = (ClauseUnion *)ClauseCodeToStaticIndex(ipc);
4735 }
4736 return sp+1;
4737 }
4738
4739 static path_stack_entry *
cross_block(path_stack_entry * sp,yamop ** pipc,PredEntry * ap,struct intermediates * cint)4740 cross_block(path_stack_entry *sp, yamop **pipc, PredEntry *ap, struct intermediates *cint)
4741 {
4742 yamop *ipc = *pipc;
4743 path_stack_entry *tsp = sp;
4744 ClauseUnion *block;
4745
4746 do {
4747 UInt bsize;
4748 while ((--tsp)->flag != block_entry);
4749 block = tsp->u.cle.block;
4750 if (block->lui.ClFlags & LogUpdMask)
4751 bsize = block->lui.ClSize;
4752 else
4753 bsize = block->si.ClSize;
4754 if (ipc > (yamop *)block &&
4755 ipc < (yamop *)((CODEADDR)block + bsize)) {
4756 path_stack_entry *nsp = tsp+1;
4757 for (;tsp<sp;tsp++) {
4758 if (tsp->flag == pc_entry) {
4759 if (nsp != tsp) {
4760 nsp->flag = pc_entry;
4761 nsp->u.pce.pi_pc = tsp->u.pce.pi_pc;
4762 nsp->u.pce.code = tsp->u.pce.code;
4763 nsp->u.pce.current_code = tsp->u.pce.current_code;
4764 nsp->u.pce.work_pc = tsp->u.pce.work_pc;
4765 nsp->u.pce.tag = tsp->u.pce.tag;
4766 }
4767 nsp++;
4768 }
4769 }
4770 return nsp;
4771 }
4772 } while (tsp->u.cle.entry_code != NULL);
4773 /* moved to a new block */
4774 return fetch_new_block(sp, pipc, ap, cint);
4775 }
4776
4777
4778 static yamop *
pop_path(path_stack_entry ** spp,ClauseDef * clp,PredEntry * ap,struct intermediates * cint)4779 pop_path(path_stack_entry **spp, ClauseDef *clp, PredEntry *ap, struct intermediates *cint)
4780 {
4781 path_stack_entry *sp = *spp;
4782 yamop *nipc;
4783
4784 while ((--sp)->flag != pc_entry);
4785 *spp = sp;
4786 clp->Code = sp->u.pce.code;
4787 clp->CurrentCode = sp->u.pce.current_code;
4788 clp->u.WorkPC = sp->u.pce.work_pc;
4789 clp->Tag = sp->u.pce.tag;
4790 if (sp->u.pce.pi_pc == NULL) {
4791 *spp = sp;
4792 return NULL;
4793 }
4794 nipc = *(sp->u.pce.pi_pc);
4795 *spp = cross_block(sp, sp->u.pce.pi_pc, ap, cint);
4796 return nipc;
4797 }
4798
4799 static int
table_fe_overflow(yamop * pc,Functor f)4800 table_fe_overflow(yamop *pc, Functor f)
4801 {
4802 if (pc->u.sssl.s <= MIN_HASH_ENTRIES) {
4803 /* we cannot expand otherwise */
4804 COUNT i;
4805 FuncSwiEntry *csw = (FuncSwiEntry *)pc->u.sssl.l;
4806
4807 for (i=0; i < pc->u.sssl.s; i++,csw++) {
4808 if (csw->Tag == f) return FALSE;
4809 }
4810 return TRUE;
4811 } else {
4812 COUNT free = pc->u.sssl.s-pc->u.sssl.e;
4813 return (!free || pc->u.sssl.s/free > 4);
4814 }
4815 }
4816
4817 static int
table_ae_overflow(yamop * pc,Term at)4818 table_ae_overflow(yamop *pc, Term at)
4819 {
4820 if (pc->u.sssl.s <= MIN_HASH_ENTRIES) {
4821 /* check if we are already there */
4822 COUNT i;
4823 AtomSwiEntry *csw = (AtomSwiEntry *)pc->u.sssl.l;
4824
4825 for (i=0; i < pc->u.sssl.s; i++,csw++) {
4826 if (csw->Tag == at) return FALSE;
4827 }
4828 return TRUE;
4829 } else {
4830 COUNT free = pc->u.sssl.s-pc->u.sssl.e;
4831 return (!free || pc->u.sssl.s/free > 4);
4832 }
4833 }
4834
4835 static void
replace_index_block(ClauseUnion * parent_block,yamop * cod,yamop * ncod,PredEntry * ap)4836 replace_index_block(ClauseUnion *parent_block, yamop *cod, yamop *ncod, PredEntry *ap)
4837 {
4838 if (ap->PredFlags & LogUpdatePredFlag) {
4839 LogUpdIndex
4840 *cl = ClauseCodeToLogUpdIndex(cod),
4841 *ncl = ClauseCodeToLogUpdIndex(ncod),
4842 *c = parent_block->lui.ChildIndex;
4843 ncl->SiblingIndex = cl->SiblingIndex;
4844 ncl->PrevSiblingIndex = cl->PrevSiblingIndex;
4845 ncl->ClRefCount = cl->ClRefCount;
4846 ncl->ChildIndex = cl->ChildIndex;
4847 ncl->ParentIndex = cl->ParentIndex;
4848 ncl->ClPred = cl->ClPred;
4849 // INIT_LOCK(ncl->ClLock);
4850 if (c == cl) {
4851 parent_block->lui.ChildIndex = ncl;
4852 } else {
4853 if (cl->PrevSiblingIndex)
4854 cl->PrevSiblingIndex->SiblingIndex = ncl;
4855 }
4856 if (cl->SiblingIndex) {
4857 cl->SiblingIndex->PrevSiblingIndex = ncl;
4858 }
4859 c = cl->ChildIndex;
4860 while (c != NULL) {
4861 c->ParentIndex = ncl;
4862 c = c->SiblingIndex;
4863 }
4864 Yap_InformOfRemoval((CODEADDR)cl);
4865 Yap_LUIndexSpace_SW -= cl->ClSize;
4866 Yap_FreeCodeSpace((char *)cl);
4867 } else {
4868 StaticIndex
4869 *cl = ClauseCodeToStaticIndex(cod),
4870 *ncl = ClauseCodeToStaticIndex(ncod),
4871 *c = parent_block->si.ChildIndex;
4872 ncl->SiblingIndex = cl->SiblingIndex;
4873 ncl->ClPred = cl->ClPred;
4874 if (c == cl) {
4875 parent_block->si.ChildIndex = ncl;
4876 } else {
4877 while (c->SiblingIndex != cl) {
4878 c = c->SiblingIndex;
4879 }
4880 c->SiblingIndex = ncl;
4881 }
4882 Yap_InformOfRemoval((CODEADDR)cl);
4883 Yap_IndexSpace_SW -= cl->ClSize;
4884 Yap_FreeCodeSpace((char *)cl);
4885 }
4886 }
4887
4888 static AtomSwiEntry *
expand_ctable(yamop * pc,ClauseUnion * blk,struct intermediates * cint,Term at)4889 expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at)
4890 {
4891 PredEntry *ap = cint->CurrentPred;
4892 int n = pc->u.sssl.s, i, i0 = n;
4893 UInt fail_l = Zero;
4894 AtomSwiEntry *old_ae = (AtomSwiEntry *)(pc->u.sssl.l), *target;
4895
4896 if (n > MIN_HASH_ENTRIES) {
4897 AtomSwiEntry *tmp = old_ae;
4898 int i;
4899
4900 n = 1;
4901 for (i = 0; i < pc->u.sssl.s; i++,tmp++) {
4902 if (tmp->Tag != Zero) n++;
4903 else fail_l = tmp->u.Label;
4904 }
4905 } else {
4906 fail_l = old_ae[n].u.Label;
4907 n++;
4908 }
4909 if (n > MIN_HASH_ENTRIES) {
4910 int cases = MIN_HASH_ENTRIES, i, n0;
4911 n0 = n+1+n/4;
4912 while (cases < n0) cases *= 2;
4913 if (cases == pc->u.sssl.s) {
4914 return fetch_centry(old_ae, at, n-1, n);
4915 }
4916 /* initialise */
4917 target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint, 0);
4918 pc->opc = Yap_opcode(_switch_on_cons);
4919 pc->u.sssl.s = cases;
4920 for (i=0; i<cases; i++) {
4921 target[i].Tag = Zero;
4922 target[i].u.Label = fail_l;
4923 }
4924 } else {
4925 pc->opc = Yap_opcode(_if_cons);
4926 pc->u.sssl.s = n;
4927 target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
4928 target[n].Tag = Zero;
4929 target[n].u.Label = fail_l;
4930 }
4931 for (i = 0; i < i0; i++,old_ae++) {
4932 Term tag = old_ae->Tag;
4933
4934 if (tag != Zero) {
4935 AtomSwiEntry *ics = fetch_centry(target, tag, i, n);
4936 ics->Tag = tag;
4937 ics->u.Label = old_ae->u.Label;
4938 }
4939 }
4940 /* support for threads */
4941 if (blk)
4942 replace_index_block(blk, pc->u.sssl.l, (yamop *)target, ap);
4943 pc->u.sssl.l = (yamop *)target;
4944 return fetch_centry(target, at, n-1, n);
4945 }
4946
4947 static FuncSwiEntry *
expand_ftable(yamop * pc,ClauseUnion * blk,struct intermediates * cint,Functor f)4948 expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f)
4949 {
4950 PredEntry *ap = cint->CurrentPred;
4951 int n = pc->u.sssl.s, i, i0 = n;
4952 UInt fail_l = Zero;
4953 FuncSwiEntry *old_fe = (FuncSwiEntry *)(pc->u.sssl.l), *target;
4954
4955 if (n > MIN_HASH_ENTRIES) {
4956 FuncSwiEntry *tmp = old_fe;
4957 int i;
4958
4959 n = 1;
4960 for (i = 0; i < pc->u.sssl.s; i++,tmp++) {
4961 if (tmp->Tag != Zero) n++;
4962 else fail_l = tmp->u.Label;
4963 }
4964 } else {
4965 fail_l = old_fe[n].u.Label;
4966 n++;
4967 }
4968 if (n > MIN_HASH_ENTRIES) {
4969 int cases = MIN_HASH_ENTRIES, i, n0;
4970 n0 = n+1+n/4;
4971 while (cases < n0) cases *= 2;
4972
4973 if (cases == pc->u.sssl.s) {
4974 return fetch_fentry(old_fe, f, n-1, n);
4975 }
4976 pc->opc = Yap_opcode(_switch_on_func);
4977 pc->u.sssl.s = cases;
4978 pc->u.sssl.e = n;
4979 pc->u.sssl.w = 0;
4980 /* initialise */
4981 target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
4982 for (i=0; i<cases; i++) {
4983 target[i].Tag = NULL;
4984 target[i].u.Label = fail_l;
4985 }
4986 } else {
4987 pc->opc = Yap_opcode(_if_func);
4988 pc->u.sssl.s = n;
4989 pc->u.sssl.e = n;
4990 pc->u.sssl.w = 0;
4991 target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
4992 target[n].Tag = Zero;
4993 target[n].u.Label = fail_l;
4994 }
4995 for (i = 0; i < i0; i++,old_fe++) {
4996 Functor f = old_fe->Tag;
4997
4998 if (f != NULL) {
4999 FuncSwiEntry *ifs = fetch_fentry(target, f, i, n);
5000 ifs->Tag = old_fe->Tag;
5001 ifs->u.Label = old_fe->u.Label;
5002 }
5003 }
5004 replace_index_block(blk, pc->u.sssl.l, (yamop *)target, ap);
5005 pc->u.sssl.l = (yamop *)target;
5006 return fetch_fentry(target, f, n-1, n);
5007 }
5008
5009 static void
clean_ref_to_clause(LogUpdClause * tgl)5010 clean_ref_to_clause(LogUpdClause *tgl)
5011 {
5012 tgl->ClRefCount--;
5013 if ((tgl->ClFlags & ErasedMask) &&
5014 !(tgl->ClRefCount) &&
5015 !(tgl->ClFlags & InUseMask)) {
5016 /* last ref to the clause */
5017 Yap_ErLogUpdCl(tgl);
5018 }
5019 }
5020
5021
5022 static ClauseUnion *
current_block(path_stack_entry * sp)5023 current_block(path_stack_entry *sp)
5024 {
5025 while ((--sp)->flag != block_entry);
5026 return sp->u.cle.block;
5027 }
5028
5029 static path_stack_entry *
kill_block(path_stack_entry * sp,PredEntry * ap)5030 kill_block(path_stack_entry *sp, PredEntry *ap)
5031 {
5032 while ((--sp)->flag != block_entry);
5033 if (sp->u.cle.entry_code == NULL) {
5034 Yap_kill_iblock(sp->u.cle.block, NULL, ap);
5035 } else {
5036 path_stack_entry *nsp = sp;
5037
5038 while ((--nsp)->flag != block_entry);
5039 Yap_kill_iblock(sp->u.cle.block, nsp->u.cle.block, ap);
5040 *sp->u.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode);
5041 }
5042 return sp;
5043 }
5044
5045 static LogUpdClause *
find_last_clause(yamop * start)5046 find_last_clause(yamop *start)
5047 {
5048 while (start->u.OtaLl.d->ClFlags & ErasedMask)
5049 start = start->u.OtaLl.n;
5050 /* this should be the available clause */
5051 return start->u.OtaLl.d;
5052 }
5053
5054 static void
remove_clause_from_index(yamop * header,LogUpdClause * cl)5055 remove_clause_from_index(yamop *header, LogUpdClause *cl)
5056 {
5057 yamop **prevp = &(header->u.Ills.l1);
5058 yamop *curp = header->u.Ills.l1;
5059
5060 if (curp->u.OtaLl.d == cl) {
5061 yamop *newp = curp->u.OtaLl.n;
5062 newp->opc = curp->opc;
5063 *prevp = newp;
5064 } else {
5065 yamop *ocurp = NULL, *ocurp0 = curp;
5066
5067 while (curp->u.OtaLl.d != cl) {
5068 ocurp = curp;
5069 curp = curp->u.OtaLl.n;
5070 }
5071 /* in case we were the last */
5072 if (curp == header->u.Ills.l2)
5073 header->u.Ills.l2 = ocurp;
5074 if (ocurp != ocurp0)
5075 ocurp->opc = curp->opc;
5076 ocurp->u.OtILl.n = curp->u.OtaLl.n;
5077 ocurp->u.OtILl.block = curp->u.OtILl.block;
5078 }
5079 #ifdef DEBUG
5080 Yap_DirtyCps--;
5081 Yap_FreedCps++;
5082 #endif
5083 clean_ref_to_clause(cl);
5084 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtILl);
5085 Yap_FreeCodeSpace((ADDR)curp);
5086 }
5087
5088 static void
remove_dirty_clauses_from_index(yamop * header)5089 remove_dirty_clauses_from_index(yamop *header)
5090 {
5091 LogUpdClause *cl;
5092 yamop *previouscurp;
5093 OPCODE endop = Yap_opcode(_trust_logical);
5094 yamop **prevp= &(header->u.Ills.l1), *curp = header->u.Ills.l1;
5095 OPCODE startopc = curp->opc;
5096 PredEntry *ap = curp->u.OtaLl.d->ClPred;
5097
5098 if (ap->PredFlags & CountPredFlag)
5099 endop = Yap_opcode(_count_trust_logical);
5100 else if (ap->PredFlags & ProfiledPredFlag)
5101 endop = Yap_opcode(_profiled_trust_logical);
5102 while ((cl = curp->u.OtaLl.d)->ClFlags & ErasedMask) {
5103 yamop *ocurp = curp;
5104
5105 #ifdef DEBUG
5106 Yap_DirtyCps--;
5107 Yap_FreedCps++;
5108 #endif
5109 clean_ref_to_clause(cl);
5110 curp = curp->u.OtaLl.n;
5111 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtaLl);
5112 Yap_FreeCodeSpace((ADDR)ocurp);
5113 }
5114 *prevp = curp;
5115 curp->opc = startopc;
5116 if (curp->opc == endop)
5117 return;
5118 previouscurp = curp;
5119 curp = curp->u.OtaLl.n;
5120 while (TRUE) {
5121 if ((cl = curp->u.OtaLl.d)->ClFlags & ErasedMask) {
5122 yamop *ocurp = curp;
5123
5124 #ifdef DEBUG
5125 Yap_DirtyCps--;
5126 Yap_FreedCps++;
5127 #endif
5128 clean_ref_to_clause(cl);
5129 if (curp->opc == endop) {
5130 previouscurp->opc = endop;
5131 previouscurp->u.OtILl.block = curp->u.OtILl.block;
5132 previouscurp->u.OtILl.n = NULL;
5133 header->u.Ills.l2 = previouscurp;
5134 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtILl);
5135 Yap_FreeCodeSpace((ADDR)curp);
5136 return;
5137 }
5138 previouscurp->u.OtaLl.n = curp->u.OtaLl.n;
5139 curp = curp->u.OtaLl.n;
5140 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop*)NULL,OtaLl);
5141 Yap_FreeCodeSpace((ADDR)ocurp);
5142 } else {
5143 previouscurp = curp;
5144 if (curp->opc == endop) {
5145 curp->u.OtILl.n = NULL;
5146 return;
5147 }
5148 curp = curp->u.OtaLl.n;
5149 }
5150 }
5151 }
5152
5153 static path_stack_entry *
kill_clause(yamop * ipc,yamop * bg,yamop * lt,path_stack_entry * sp0,PredEntry * ap)5154 kill_clause(yamop *ipc, yamop *bg, yamop *lt, path_stack_entry *sp0, PredEntry *ap)
5155 {
5156 LogUpdIndex *blk;
5157 yamop *start;
5158 op_numbers op0;
5159 path_stack_entry *sp = sp0;
5160
5161 while ((--sp)->flag != block_entry);
5162 blk = (LogUpdIndex *)(sp->u.cle.block);
5163 start = blk->ClCode;
5164 op0 = Yap_op_from_opcode(start->opc);
5165 while (op0 == _lock_lu) {
5166 start = NEXTOP(start, p);
5167 op0 = Yap_op_from_opcode(start->opc);
5168 }
5169 while (op0 == _jump_if_nonvar) {
5170 start = NEXTOP(start, xll);
5171 op0 = Yap_op_from_opcode(start->opc);
5172 }
5173 if (op0 != _enter_lu_pred) {
5174 /* static code */
5175 return kill_block(sp+1, ap);
5176 }
5177 /* weird case ????? */
5178 if (!start->u.Ills.s){
5179 /* ERROR */
5180 Yap_Error(INTERNAL_ERROR, TermNil, "Ills.s == 0 %p", ipc);
5181 return sp;
5182 }
5183 if (start->u.Ills.s == 1) {
5184 /* we need to discover which clause is left and then die */
5185 path_stack_entry *nsp;
5186 LogUpdClause *tgl = find_last_clause(start->u.Ills.l1);
5187
5188 nsp = sp;
5189 while ((--nsp)->flag != block_entry);
5190 /* make us point straight at clause */
5191 *sp->u.cle.entry_code = tgl->ClCode;
5192 Yap_kill_iblock(sp->u.cle.block, nsp->u.cle.block, ap);
5193 return sp;
5194 } else {
5195 if (
5196 #if defined(YAPOR) || defined(THREADS)
5197 blk->ClRefCount == 0
5198 #else
5199 !(blk->ClFlags & InUseMask)
5200 #endif
5201 ) {
5202 remove_clause_from_index(start,
5203 ClauseCodeToLogUpdClause(bg));
5204 } else {
5205 blk->ClFlags |= DirtyMask;
5206 }
5207 return sp;
5208 }
5209 }
5210
5211 static path_stack_entry *
expanda_block(path_stack_entry * sp,PredEntry * ap,ClauseDef * cls,int group1,yamop * alt,struct intermediates * cint)5212 expanda_block(path_stack_entry *sp, PredEntry *ap, ClauseDef *cls, int group1, yamop *alt, struct intermediates *cint)
5213 {
5214 while ((--sp)->flag != block_entry);
5215 Yap_kill_iblock(sp->u.cle.block, NULL, ap);
5216 return sp;
5217 }
5218
5219 static path_stack_entry *
expandz_block(path_stack_entry * sp,PredEntry * ap,ClauseDef * cls,int group1,yamop * alt,struct intermediates * cint)5220 expandz_block(path_stack_entry *sp, PredEntry *ap, ClauseDef *cls, int group1, yamop *alt, struct intermediates *cint)
5221 {
5222 while ((--sp)->flag != block_entry);
5223 Yap_kill_iblock(sp->u.cle.block, NULL, ap);
5224 return sp;
5225 }
5226
5227 static LogUpdClause *
lu_clause(yamop * ipc,PredEntry * ap)5228 lu_clause(yamop *ipc, PredEntry *ap)
5229 {
5230 if (ipc == FAILCODE)
5231 return NULL;
5232 if (ipc == (yamop *)(&(ap->OpcodeOfPred)))
5233 return NULL;
5234 return ClauseCodeToLogUpdClause(ipc);
5235 }
5236
5237 static StaticClause *
find_static_clause(PredEntry * ap,yamop * ipc)5238 find_static_clause(PredEntry *ap, yamop *ipc)
5239 {
5240 StaticClause *cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
5241 while (ipc < cl->ClCode ||
5242 ipc > (yamop *)((char *)cl+ cl->ClSize)) {
5243 cl = cl->ClNext;
5244 if (!cl)
5245 return NULL;
5246 }
5247 return cl;
5248 }
5249
5250 static StaticClause *
static_clause(yamop * ipc,PredEntry * ap,int trust)5251 static_clause(yamop *ipc, PredEntry *ap, int trust)
5252 {
5253 CELL *p;
5254
5255 if (ipc == FAILCODE)
5256 return NULL;
5257 if (ipc == (yamop*)(&(ap->OpcodeOfPred)))
5258 return NULL;
5259 if (ap->PredFlags & MegaClausePredFlag)
5260 return (StaticClause *)ipc;
5261 if (ap->PredFlags & TabledPredFlag)
5262 ipc = PREVOP(ipc,Otapl);
5263 p = (CELL *)ipc;
5264 if (trust) {
5265 return ClauseCodeToStaticClause(p);
5266 } else {
5267 op_numbers op = Yap_op_from_opcode(ipc->opc);
5268 UInt j;
5269
5270 /* unbound call, so we cannot optimise instructions */
5271 switch (op) {
5272 case _p_db_ref_x:
5273 case _p_float_x:
5274 j = Yap_regnotoreg(ipc->u.xl.x);
5275 break;
5276 case _get_list:
5277 j = Yap_regnotoreg(ipc->u.x.x);
5278 break;
5279 case _get_atom:
5280 j = Yap_regnotoreg(ipc->u.xc.x);
5281 break;
5282 case _get_float:
5283 j = Yap_regnotoreg(ipc->u.xd.x);
5284 break;
5285 case _get_struct:
5286 j = Yap_regnotoreg(ipc->u.xd.x);
5287 break;
5288 case _get_2atoms:
5289 case _get_3atoms:
5290 case _get_4atoms:
5291 case _get_5atoms:
5292 case _get_6atoms:
5293 return ClauseCodeToStaticClause(p);
5294 default:
5295 return find_static_clause(ap, ipc);
5296 }
5297 if (j == 1) /* must be the first instruction */
5298 return ClauseCodeToStaticClause(p);
5299 return find_static_clause(ap, ipc);
5300 }
5301 return NULL;
5302 }
5303
5304 static StaticClause *
simple_static_clause(yamop * ipc,PredEntry * ap)5305 simple_static_clause(yamop *ipc, PredEntry *ap)
5306 {
5307 if (ipc == (yamop*)(&(ap->OpcodeOfPred)))
5308 return NULL;
5309 if (ipc == FAILCODE)
5310 return NULL;
5311 return ClauseCodeToStaticClause(ipc);
5312 }
5313
5314 /* this code should be called when we jumped to clauses */
5315 static path_stack_entry *
kill_unsafe_block(path_stack_entry * sp,op_numbers op,PredEntry * ap,int first,int remove,ClauseDef * cls)5316 kill_unsafe_block(path_stack_entry *sp, op_numbers op, PredEntry *ap, int first, int remove, ClauseDef *cls)
5317 {
5318 yamop *ipc;
5319 while ((--sp)->flag != block_entry);
5320 if (sp->u.cle.entry_code == NULL) {
5321 /* we have reached the top */
5322 Yap_RemoveIndexation(ap);
5323 return sp;
5324 }
5325 ipc = *sp->u.cle.entry_code;
5326 if (Yap_op_from_opcode(ipc->opc) == op) {
5327 /* the new block was the current clause */
5328 ClauseDef cld[2];
5329
5330 if (remove) {
5331 *sp->u.cle.entry_code = FAILCODE;
5332 return sp;
5333 }
5334 if (ap->PredFlags & LogUpdatePredFlag) {
5335 struct intermediates intrs;
5336 LogUpdClause *lc = lu_clause(ipc, ap);
5337
5338 if (first) {
5339 cld[0].Code = cls[0].Code;
5340 cld[1].Code = lc->ClCode;
5341 } else {
5342 cld[0].Code = lc->ClCode;
5343 cld[1].Code = cls[0].Code;
5344 }
5345 intrs.expand_block = NULL;
5346 *sp->u.cle.entry_code = (yamop *)suspend_indexing(cld, cld+1, ap, &intrs);
5347 } else {
5348 /* static predicate, shouldn't do much, just suspend the code here */
5349 *sp->u.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode);
5350 return sp;
5351 }
5352 return sp;
5353 }
5354 /* we didn't have protection, should kill now */
5355 return kill_block(sp+1, ap);
5356 }
5357
5358 static int
compacta_expand_clauses(yamop * ipc)5359 compacta_expand_clauses(yamop *ipc)
5360 {
5361 /* expand clauses so that you have a hole at the beginning */
5362 /* we know that there is at least one element here */
5363 yamop **start = (yamop **)(NEXTOP(ipc,sssllp));
5364 yamop **ptr, **end;
5365
5366 ptr = end = start+ipc->u.sssllp.s1;
5367
5368 while (ptr > start) {
5369 yamop *next = *--ptr;
5370 if (next) *--end = next;
5371 }
5372 if (ptr != end) {
5373 while (end > start) {
5374 *--end = NULL;
5375 }
5376 return TRUE;
5377 }
5378 return FALSE;
5379 }
5380
5381 static int
compactz_expand_clauses(yamop * ipc)5382 compactz_expand_clauses(yamop *ipc)
5383 {
5384 /* expand clauses so that you have a hole at the beginning */
5385 /* we know that there is at least one element here */
5386 yamop **start = (yamop **)(NEXTOP(ipc,sssllp));
5387 yamop **ptr, **end;
5388
5389 end = start+ipc->u.sssllp.s1;
5390 ptr = start;
5391
5392 while (ptr < end) {
5393 yamop *next = *ptr++;
5394 if (next) *start++ = next;
5395 }
5396 /* reset empty slots at end */
5397 if (start != end) {
5398 while (start < end) {
5399 *start++ = NULL;
5400 }
5401 return TRUE;
5402 }
5403 return FALSE;
5404 }
5405
5406 /* this code should be called when we jumped to clauses */
5407 static yamop *
add_to_expand_clauses(path_stack_entry ** spp,yamop * ipc,ClauseDef * cls,PredEntry * ap,int first,struct intermediates * cint)5408 add_to_expand_clauses(path_stack_entry **spp, yamop *ipc, ClauseDef *cls, PredEntry *ap, int first, struct intermediates *cint)
5409 {
5410 path_stack_entry *sp = *spp;
5411 yamop **clar;
5412
5413 if (first) {
5414
5415 do {
5416 clar = (yamop **)NEXTOP(ipc,sssllp);
5417
5418 if (*clar == NULL || clar[0] == cls->Code) {
5419 while (*clar == NULL) clar++;
5420 if (clar[0] != cls->Code) {
5421 clar[-1] = cls->Code;
5422 ipc->u.sssllp.s2++;
5423 }
5424 return pop_path(spp, cls, ap, cint);
5425 }
5426 } while (compacta_expand_clauses(ipc));
5427 } else {
5428 do {
5429 clar = (yamop **)NEXTOP(ipc,sssllp) + ipc->u.sssllp.s1;
5430 if (clar[-1] == NULL || clar[-1] == cls->Code) {
5431 while (*--clar == NULL);
5432 if (clar[0] != cls->Code) {
5433 clar[1] = cls->Code;
5434 ipc->u.sssllp.s2++;
5435 }
5436 return pop_path(spp, cls, ap, cint);
5437 }
5438 } while (compactz_expand_clauses(ipc));
5439 }
5440 while ((--sp)->flag != block_entry);
5441 if (sp->u.cle.entry_code) {
5442 *sp->u.cle.entry_code = (yamop *)&(ap->cs.p_code.ExpandCode);
5443 }
5444 recover_ecls_block(ipc);
5445 return pop_path(spp, cls, ap, cint);
5446 }
5447
5448 /* this code should be called when we jumped to clauses */
5449 static void
nullify_expand_clause(yamop * ipc,path_stack_entry * sp,ClauseDef * cls)5450 nullify_expand_clause(yamop *ipc, path_stack_entry *sp, ClauseDef *cls)
5451 {
5452 yamop **st = (yamop **)NEXTOP(ipc,sssllp);
5453 yamop **max = st+ipc->u.sssllp.s1;
5454
5455 /* make sure we get rid of the reference */
5456 while (st < max) {
5457 if (*st && *st == cls->Code) {
5458 *st = NULL;
5459 ipc->u.sssllp.s2--;
5460 break;
5461 }
5462 st++;
5463 }
5464 /* if the block has a single element */
5465 if (ipc->u.sssllp.s2 == 1) {
5466 yamop **st = (yamop **)NEXTOP(ipc,sssllp);
5467 while ((--sp)->flag != block_entry);
5468 while (TRUE) {
5469 if (*st && *st != cls->Code) {
5470 *sp->u.cle.entry_code = *st;
5471 recover_ecls_block(ipc);
5472 return;
5473 }
5474 st++;
5475 }
5476 }
5477 }
5478
5479 static yamop *
add_try(PredEntry * ap,ClauseDef * cls,yamop * next,struct intermediates * cint)5480 add_try(PredEntry *ap, ClauseDef *cls, yamop *next, struct intermediates *cint)
5481 {
5482 yamop *newcp;
5483 UInt size = (UInt)NEXTOP((yamop *)NULL,OtaLl);
5484 LogUpdClause *lcl = ClauseCodeToLogUpdClause(cls->Code);
5485
5486 if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) {
5487 /* OOOPS, got in trouble, must do a siglongjmp and recover space */
5488 save_machine_regs();
5489 siglongjmp(cint->CompilerBotch,2);
5490 }
5491 Yap_LUIndexSpace_CP += size;
5492 #ifdef DEBUG
5493 Yap_NewCps++;
5494 Yap_LiveCps++;
5495 #endif
5496 newcp->opc = Yap_opcode(_try_logical);
5497 newcp->u.OtaLl.s = ap->ArityOfPE;
5498 newcp->u.OtaLl.n = next;
5499 newcp->u.OtaLl.d = lcl;
5500 lcl->ClRefCount++;
5501 return newcp;
5502 }
5503
5504 static yamop *
add_trust(LogUpdIndex * icl,ClauseDef * cls,struct intermediates * cint)5505 add_trust(LogUpdIndex *icl, ClauseDef *cls, struct intermediates *cint)
5506 {
5507 yamop *newcp;
5508 UInt size = (UInt)NEXTOP((yamop *)NULL,OtILl);
5509 LogUpdClause *lcl = ClauseCodeToLogUpdClause(cls->Code);
5510 PredEntry *ap = lcl->ClPred;
5511
5512 if ((newcp = (yamop *)Yap_AllocCodeSpace(size)) == NULL) {
5513 /* OOOPS, got in trouble, must do a siglongjmp and recover space */
5514 save_machine_regs();
5515 siglongjmp(cint->CompilerBotch,2);
5516 }
5517 Yap_LUIndexSpace_CP += size;
5518 #ifdef DEBUG
5519 Yap_NewCps++;
5520 Yap_LiveCps++;
5521 #endif
5522 if (ap->PredFlags & CountPredFlag)
5523 newcp->opc = Yap_opcode(_count_trust_logical);
5524 else if (ap->PredFlags & ProfiledPredFlag)
5525 newcp->opc = Yap_opcode(_profiled_trust_logical);
5526 else
5527 newcp->opc = Yap_opcode(_trust_logical);
5528 newcp->u.OtILl.block = icl;
5529 newcp->u.OtILl.n = NULL;
5530 newcp->u.OtILl.d = lcl;
5531 lcl->ClRefCount++;
5532 return newcp;
5533 }
5534
5535 static void
add_to_index(struct intermediates * cint,int first,path_stack_entry * sp,ClauseDef * cls)5536 add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, ClauseDef *cls) {
5537 /* last clause to experiment with */
5538 PredEntry *ap = cint->CurrentPred;
5539 yamop *ipc = ap->cs.p_code.TrueCodeOfPred;
5540 int group1 = TRUE;
5541 yamop *alt = NULL;
5542 UInt current_arity = 0;
5543 int last_arg = TRUE;
5544 LogUpdIndex *icl = NULL;
5545
5546 sp = init_block_stack(sp, ipc, ap);
5547 /* try to refine the interval using the indexing code */
5548 while (ipc != NULL) {
5549 op_numbers op = Yap_op_from_opcode(ipc->opc);
5550
5551 switch(op) {
5552 case _try_logical:
5553 case _retry_logical:
5554 case _count_retry_logical:
5555 case _profiled_retry_logical:
5556 case _trust_logical:
5557 case _count_trust_logical:
5558 case _profiled_trust_logical:
5559 /* ERROR */
5560 break;
5561 case _enter_lu_pred:
5562 ipc->u.Ills.s++;
5563 icl = ipc->u.Ills.I;
5564 if (first) {
5565 if (ap->PredFlags & CountPredFlag)
5566 ipc->u.Ills.l1->opc = Yap_opcode(_count_retry_logical);
5567 else if (ap->PredFlags & ProfiledPredFlag)
5568 ipc->u.Ills.l1->opc = Yap_opcode(_profiled_retry_logical);
5569 else
5570 ipc->u.Ills.l1->opc = Yap_opcode(_retry_logical);
5571 ipc->u.Ills.l1 = add_try(ap, cls, ipc->u.Ills.l1, cint);
5572 } else {
5573 /* just go to next instruction */
5574 yamop *end = add_trust(icl, cls, cint),
5575 *old = ipc->u.Ills.l2;
5576
5577 /* we used to have two clauses */
5578 if (ap->PredFlags & CountPredFlag)
5579 old->opc = Yap_opcode(_count_retry_logical);
5580 else if (ap->PredFlags & ProfiledPredFlag)
5581 old->opc = Yap_opcode(_profiled_retry_logical);
5582 else
5583 old->opc = Yap_opcode(_retry_logical);
5584 old->u.OtaLl.n = end;
5585 old->u.OtaLl.s = ap->ArityOfPE;
5586 ipc->u.Ills.l2 = end;
5587 }
5588 ipc = pop_path(&sp, cls, ap, cint);
5589 break;
5590 case _try_clause:
5591 /* I cannot expand a predicate that starts on a variable,
5592 have to expand the index.
5593 */
5594 if (first) {
5595 sp = expanda_block(sp, ap, cls, group1, alt, cint);
5596 ipc = pop_path(&sp, cls, ap, cint);
5597 } else {
5598 /* just go to next instruction */
5599 ipc = NEXTOP(ipc,Otapl);
5600 }
5601 break;
5602 case _try_clause2:
5603 case _try_clause3:
5604 case _try_clause4:
5605 /* I cannot expand a predicate that starts on a variable,
5606 have to expand the index.
5607 */
5608 if (first) {
5609 sp = expanda_block(sp, ap, cls, group1, alt, cint);
5610 ipc = pop_path(&sp, cls, ap, cint);
5611 } else {
5612 /* just go to next instruction */
5613 ipc = NEXTOP(ipc,l);
5614 }
5615 break;
5616 case _retry:
5617 /* this clause had no indexing */
5618 ipc = NEXTOP(ipc,Otapl);
5619 break;
5620 case _retry2:
5621 case _retry3:
5622 case _retry4:
5623 /* this clause had no indexing */
5624 ipc = NEXTOP(ipc,l);
5625 break;
5626 /* instructions type l */
5627 case _retry_me:
5628 /* should never be reached both for asserta */
5629 group1 = FALSE;
5630 ipc = ipc->u.Otapl.d;
5631 break;
5632 case _try_me:
5633 if (first) {
5634 ipc = NEXTOP(ipc,Otapl);
5635 alt = ipc->u.Otapl.d;
5636 } else {
5637 ipc = ipc->u.Otapl.d;
5638 group1 = FALSE;
5639 }
5640 break;
5641 case _retry_profiled:
5642 case _count_retry:
5643 ipc = NEXTOP(ipc,Otapl);
5644 break;
5645 case _profiled_trust_me:
5646 case _trust_me:
5647 case _count_trust_me:
5648 group1 = FALSE;
5649 ipc = NEXTOP(ipc,Otapl);
5650 break;
5651 case _trust:
5652 sp = expandz_block(sp, ap, cls, group1, alt, cint);
5653 ipc = pop_path(&sp, cls, ap, cint);
5654 break;
5655 case _jump:
5656 sp = cross_block(sp, &ipc->u.l.l, ap, cint);
5657 /* just skip for now, but should worry about memory management */
5658 ipc = ipc->u.l.l;
5659 break;
5660 case _jump_if_var:
5661 sp = push_path(sp, &(ipc->u.l.l), cls, cint);
5662 ipc = NEXTOP(ipc,l);
5663 break;
5664 case _jump_if_nonvar:
5665 sp = push_path(sp, &(ipc->u.xll.l2), cls, cint);
5666 sp = cross_block(sp, &ipc->u.xll.l1, ap, cint);
5667 ipc = ipc->u.xll.l1;
5668 break;
5669 /* instructions type EC */
5670 case _try_in:
5671 /* we are done */
5672 if (first) {
5673 sp = kill_block(sp, ap);
5674 ipc = pop_path(&sp, cls, ap, cint);
5675 } else {
5676 ipc = NEXTOP(ipc,l);
5677 }
5678 break;
5679 case _user_switch:
5680 ipc = ipc->u.lp.l;
5681 break;
5682 /* instructions type e */
5683 case _switch_on_type:
5684 sp = push_path(sp, &(ipc->u.llll.l4), cls, cint);
5685 if (ap->PredFlags & LogUpdatePredFlag) {
5686 add_head_info(cls, 1);
5687 } else {
5688 add_info(cls, 1);
5689 }
5690 if (IsPairTerm(cls->Tag)) {
5691 yamop *nipc = ipc->u.llll.l1;
5692
5693 current_arity = 2;
5694 move_next(cls, 1);
5695 if (nipc == FAILCODE) {
5696 /* jump straight to clause */
5697 if (ap->PredFlags & LogUpdatePredFlag) {
5698 ipc->u.llll.l1 = cls->Code;
5699 } else {
5700 ipc->u.llll.l1 = cls->CurrentCode;
5701 }
5702 ipc = pop_path(&sp, cls, ap, cint);
5703 } else {
5704 /* go on */
5705 sp = cross_block(sp, &ipc->u.llll.l1, ap, cint);
5706 ipc = nipc;
5707 }
5708 } else if (IsAtomOrIntTerm(cls->Tag)) {
5709 yamop *nipc = ipc->u.llll.l2;
5710 move_next(cls, 1);
5711 if (nipc == FAILCODE) {
5712 /* need to expand the block */
5713 sp = kill_block(sp, ap);
5714 ipc = pop_path(&sp, cls, ap, cint);
5715 } else {
5716 /* I do not have to worry about crossing a block here */
5717 ipc = nipc;
5718 }
5719 } else if (IsApplTerm(cls->Tag)) {
5720 yamop *nipc = ipc->u.llll.l3;
5721 if (nipc == FAILCODE) {
5722 /* need to expand the block */
5723 sp = kill_block(sp, ap);
5724 ipc = pop_path(&sp, cls, ap, cint);
5725 } else {
5726 /* I do not have to worry about crossing a block here */
5727 ipc = nipc;
5728 }
5729 } else {
5730 /* we can't separate into four groups,
5731 need to restart.
5732 */
5733 sp = kill_block(sp, ap);
5734 ipc = pop_path(&sp, cls, ap, cint);
5735 }
5736 break;
5737 case _switch_list_nl:
5738 sp = kill_block(sp, ap);
5739 ipc = pop_path(&sp, cls, ap, cint);
5740 break;
5741 case _switch_on_arg_type:
5742 sp = push_path(sp, &(ipc->u.xllll.l4), cls, cint);
5743 if (ap->PredFlags & LogUpdatePredFlag) {
5744 add_head_info(cls, Yap_regtoregno(ipc->u.xllll.x));
5745 } else {
5746 add_info(cls, Yap_regtoregno(ipc->u.xllll.x));
5747 }
5748 if (IsPairTerm(cls->Tag)) {
5749 yamop *nipc = ipc->u.xllll.l1;
5750
5751 current_arity = 2;
5752 move_next(cls, Yap_regtoregno(ipc->u.xllll.x));
5753 if (nipc == FAILCODE) {
5754 /* jump straight to clause */
5755 if (ap->PredFlags & LogUpdatePredFlag) {
5756 ipc->u.xllll.l1 = cls->Code;
5757 } else {
5758 ipc->u.xllll.l1 = cls->CurrentCode;
5759 }
5760 ipc = pop_path(&sp, cls, ap, cint);
5761 } else {
5762 /* go on */
5763 sp = cross_block(sp, &ipc->u.xllll.l1, ap, cint);
5764 ipc = nipc;
5765 }
5766 } else if (IsAtomOrIntTerm(cls->Tag)) {
5767 yamop *nipc = ipc->u.xllll.l2;
5768 move_next(cls, Yap_regtoregno(ipc->u.xllll.x));
5769 if (nipc == FAILCODE) {
5770 /* need to expand the block */
5771 sp = kill_block(sp, ap);
5772 ipc = pop_path(&sp, cls, ap, cint);
5773 } else {
5774 /* I do not have to worry about crossing a block here */
5775 ipc = nipc;
5776 }
5777 } else if (IsApplTerm(cls->Tag)) {
5778 yamop *nipc = ipc->u.xllll.l3;
5779 move_next(cls, Yap_regtoregno(ipc->u.xllll.x));
5780 if (nipc == FAILCODE) {
5781 /* need to expand the block */
5782 sp = kill_block(sp, ap);
5783 ipc = pop_path(&sp, cls, ap, cint);
5784 } else {
5785 /* I do not have to worry about crossing a block here */
5786 ipc = nipc;
5787 }
5788 } else {
5789 /* we can't separate into four groups,
5790 need to restart.
5791 */
5792 sp = kill_block(sp, ap);
5793 ipc = pop_path(&sp, cls, ap, cint);
5794 }
5795 break;
5796 case _switch_on_sub_arg_type:
5797 sp = push_path(sp, &(ipc->u.sllll.l4), cls, cint);
5798 add_arg_info(cls, ap, ipc->u.sllll.s+1);
5799 if (IsPairTerm(cls->Tag)) {
5800 yamop *nipc = ipc->u.sllll.l1;
5801 current_arity = 2;
5802 skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
5803 if (current_arity != ipc->u.sllll.s+1) {
5804 last_arg = FALSE;
5805 }
5806 if (nipc == FAILCODE) {
5807 /* jump straight to clause */
5808 if (ap->PredFlags & LogUpdatePredFlag) {
5809 ipc->u.sllll.l1 = cls->Code;
5810 } else {
5811 ipc->u.sllll.l1 = cls->CurrentCode;
5812 }
5813 ipc = pop_path(&sp, cls, ap, cint);
5814 } else {
5815 /* go on */
5816 sp = cross_block(sp, &ipc->u.sllll.l1, ap, cint);
5817 ipc = nipc;
5818 }
5819 } else if (IsAtomOrIntTerm(cls->Tag)) {
5820 yamop *nipc = ipc->u.sllll.l2;
5821 skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
5822 if (current_arity != ipc->u.sllll.s+1) {
5823 last_arg = FALSE;
5824 }
5825 if (nipc == FAILCODE) {
5826 /* need to expand the block */
5827 sp = kill_block(sp, ap);
5828 ipc = pop_path(&sp, cls, ap, cint);
5829 } else {
5830 /* I do not have to worry about crossing a block here */
5831 ipc = nipc;
5832 }
5833 } else if (IsApplTerm(cls->Tag)) {
5834 yamop *nipc = ipc->u.sllll.l3;
5835 skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
5836 if (current_arity != ipc->u.sllll.s+1) {
5837 last_arg = FALSE;
5838 }
5839 if (nipc == FAILCODE) {
5840 /* need to expand the block */
5841 sp = kill_block(sp, ap);
5842 ipc = pop_path(&sp, cls, ap, cint);
5843 } else {
5844 /* I do not have to worry about crossing a block here */
5845 ipc = nipc;
5846 }
5847 } else {
5848 /* we can't separate into four groups,
5849 need to restart.
5850 */
5851 sp = kill_block(sp, ap);
5852 ipc = pop_path(&sp, cls, ap, cint);
5853 }
5854 break;
5855 case _if_not_then:
5856 ipc = pop_path(&sp, cls, ap, cint);
5857 break;
5858 /* instructions type ollll */
5859 case _switch_on_func:
5860 case _if_func:
5861 case _go_on_func:
5862 {
5863 FuncSwiEntry *fe;
5864 yamop *newpc;
5865 Functor f = (Functor)RepAppl(cls->Tag);
5866
5867 if (op == _switch_on_func) {
5868 fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s);
5869 } else {
5870 fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s);
5871 }
5872 if (!IsExtensionFunctor(f)) {
5873 current_arity = ArityOfFunctor(f);
5874 }
5875 newpc = fe->u.labp;
5876 if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) {
5877 /* we found it */
5878 ipc = pop_path(&sp, cls, ap, cint);
5879 } else if (newpc == FAILCODE) {
5880 /* oops, nothing there */
5881 if (fe->Tag != f) {
5882 if (IsExtensionFunctor(f)) {
5883 sp = kill_unsafe_block(sp, op, ap, first, FALSE, cls);
5884 ipc = pop_path(&sp, cls, ap, cint);
5885 break;
5886 }
5887 if (table_fe_overflow(ipc, f)) {
5888 fe = expand_ftable(ipc, current_block(sp), cint, f);
5889 }
5890 fe->Tag = f;
5891 ipc->u.sssl.e++;
5892 }
5893 if (ap->PredFlags & LogUpdatePredFlag) {
5894 fe->u.labp = cls->Code;
5895 } else {
5896 fe->u.labp = cls->CurrentCode;
5897 }
5898 ipc = pop_path(&sp, cls, ap, cint);
5899 } else {
5900 yamop *newpc = fe->u.labp;
5901 sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint);
5902 sp = cross_block(sp, &(fe->u.labp), ap, cint);
5903 ipc = newpc;
5904 }
5905 }
5906 break;
5907 case _index_dbref:
5908 cls->Tag = cls->u.t_ptr;
5909 ipc = NEXTOP(ipc,e);
5910 break;
5911 case _index_blob:
5912 cls->Tag = Yap_Double_key(cls->u.t_ptr);
5913 ipc = NEXTOP(ipc,e);
5914 break;
5915 case _index_long:
5916 cls->Tag = Yap_Int_key(cls->u.t_ptr);
5917 ipc = NEXTOP(ipc,e);
5918 break;
5919 case _switch_on_cons:
5920 case _if_cons:
5921 case _go_on_cons:
5922 {
5923 AtomSwiEntry *ae;
5924 yamop *newpc;
5925 Term at = cls->Tag;
5926
5927 if (op == _switch_on_cons) {
5928 ae = lookup_c_hash(at,ipc->u.sssl.l,ipc->u.sssl.s);
5929 } else {
5930 ae = lookup_c(at, ipc->u.sssl.l, ipc->u.sssl.s);
5931 }
5932 newpc = ae->u.labp;
5933
5934 if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) {
5935 /* nothing more to do */
5936 ipc = pop_path(&sp, cls, ap, cint);
5937 } else if (newpc == FAILCODE) {
5938 /* oops, nothing there */
5939 if (ae->Tag != at) {
5940 if (table_ae_overflow(ipc, at)) {
5941 ae = expand_ctable(ipc, current_block(sp), cint, at);
5942 }
5943 ae->Tag = at;
5944 ipc->u.sssl.e++;
5945 }
5946 if (ap->PredFlags & LogUpdatePredFlag) {
5947 ae->u.labp = cls->Code;
5948 } else {
5949 ae->u.labp = cls->CurrentCode;
5950 }
5951 ipc = pop_path(&sp, cls, ap, cint);
5952 } else {
5953 yamop *newpc = ae->u.labp;
5954
5955 sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint);
5956 sp = cross_block(sp, &(ae->u.labp), ap, cint);
5957 ipc = newpc;
5958 }
5959 }
5960 break;
5961 case _expand_clauses:
5962 ipc = add_to_expand_clauses(&sp, ipc, cls, ap, first, cint);
5963 break;
5964 case _expand_index:
5965 ipc = pop_path(&sp, cls, ap, cint);
5966 break;
5967 case _lock_lu:
5968 ipc = NEXTOP(ipc,p);
5969 break;
5970 case _unlock_lu:
5971 ipc = NEXTOP(ipc,e);
5972 break;
5973 case _op_fail:
5974 while ((--sp)->flag != block_entry);
5975 *sp->u.cle.entry_code = cls->Code;
5976 ipc = pop_path(&sp, cls, ap, cint);
5977 break;
5978 default:
5979 sp = kill_unsafe_block(sp, op, ap, first, FALSE, cls);
5980 ipc = pop_path(&sp, cls, ap, cint);
5981 }
5982 }
5983 }
5984
5985
5986 void
Yap_AddClauseToIndex(PredEntry * ap,yamop * beg,int first)5987 Yap_AddClauseToIndex(PredEntry *ap, yamop *beg, int first) {
5988 ClauseDef cl;
5989 /* first clause */
5990 path_stack_entry *stack, *sp;
5991 int cb;
5992 struct intermediates cint;
5993
5994 if (!(ap->PredFlags & LogUpdatePredFlag)) {
5995 if (ap->PredFlags & IndexedPredFlag)
5996 Yap_RemoveIndexation(ap);
5997 return;
5998 }
5999 cint.CurrentPred = ap;
6000 cint.expand_block = NULL;
6001 cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NIL;
6002 if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) {
6003 restore_machine_regs();
6004 Yap_gcl(Yap_Error_Size, ap->ArityOfPE, ENV, CP);
6005 save_machine_regs();
6006 } else if (cb == 2) {
6007 restore_machine_regs();
6008 Yap_growheap(FALSE, Yap_Error_Size, NULL);
6009 save_machine_regs();
6010 } else if (cb == 4) {
6011 restore_machine_regs();
6012 Yap_growtrail(Yap_Error_Size, FALSE);
6013 save_machine_regs();
6014 }
6015 if (cb) {
6016 Yap_RemoveIndexation(ap);
6017 return;
6018 }
6019 Yap_Error_Size = 0;
6020 Yap_ErrorMessage = NULL;
6021 #ifdef DEBUG
6022 if (Yap_Option['i' - 'a' + 1]) {
6023 Term tmod = ap->ModuleOfPred;
6024 Yap_LockStream(Yap_c_error_stream);
6025 if (!tmod) tmod = TermProlog;
6026 Yap_DebugPutc(Yap_c_error_stream,'+');
6027 Yap_DebugPutc(Yap_c_error_stream,'\t');
6028 Yap_DebugPlWrite(tmod);
6029 Yap_DebugPutc(Yap_c_error_stream,':');
6030 if (ap->ModuleOfPred == IDB_MODULE) {
6031 Term t = Deref(ARG1);
6032 if (IsAtomTerm(t)) {
6033 Yap_DebugPlWrite(t);
6034 } else if (IsIntegerTerm(t)) {
6035 Yap_DebugPlWrite(t);
6036 } else {
6037 Functor f = FunctorOfTerm(t);
6038 Atom At = NameOfFunctor(f);
6039 Yap_DebugPlWrite(MkAtomTerm(At));
6040 Yap_DebugPutc(Yap_c_error_stream,'/');
6041 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
6042 }
6043 } else {
6044 if (ap->ArityOfPE == 0) {
6045 Atom At = (Atom)ap->FunctorOfPred;
6046 Yap_DebugPlWrite(MkAtomTerm(At));
6047 } else {
6048 Functor f = ap->FunctorOfPred;
6049 Atom At = NameOfFunctor(f);
6050 Yap_DebugPlWrite(MkAtomTerm(At));
6051 Yap_DebugPutc(Yap_c_error_stream,'/');
6052 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
6053 }
6054 }
6055 Yap_DebugPutc(Yap_c_error_stream,'\n');
6056 Yap_UnLockStream(Yap_c_error_stream);
6057 }
6058 #endif
6059 stack = (path_stack_entry *)TR;
6060 cl.Code = cl.CurrentCode = beg;
6061 sp = push_path(stack, NULL, &cl, &cint);
6062 add_to_index(&cint, first, sp, &cl);
6063 }
6064
6065
6066 static void
contract_ftable(yamop * ipc,ClauseUnion * blk,PredEntry * ap,Functor f)6067 contract_ftable(yamop *ipc, ClauseUnion *blk, PredEntry *ap, Functor f) {
6068 int n = ipc->u.sssl.s;
6069 FuncSwiEntry *fep;
6070
6071 if (n > MIN_HASH_ENTRIES) {
6072 fep = lookup_f_hash(f, ipc->u.sssl.l, n);
6073 } else {
6074 fep = (FuncSwiEntry *)(ipc->u.sssl.l);
6075 while (fep->Tag != f) fep++;
6076 }
6077 fep->u.labp = FAILCODE;
6078 }
6079
6080 static void
contract_ctable(yamop * ipc,ClauseUnion * blk,PredEntry * ap,Term at)6081 contract_ctable(yamop *ipc, ClauseUnion *blk, PredEntry *ap, Term at) {
6082 int n = ipc->u.sssl.s;
6083 AtomSwiEntry *cep;
6084
6085 if (n > MIN_HASH_ENTRIES) {
6086 cep = lookup_c_hash(at, ipc->u.sssl.l, n);
6087 } else {
6088 cep = (AtomSwiEntry *)(ipc->u.sssl.l);
6089 while (cep->Tag != at) cep++;
6090 }
6091 cep->u.labp = FAILCODE;
6092 }
6093
6094 static void
remove_from_index(PredEntry * ap,path_stack_entry * sp,ClauseDef * cls,yamop * bg,yamop * lt,struct intermediates * cint)6095 remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg, yamop *lt, struct intermediates *cint) {
6096 /* last clause to experiment with */
6097 yamop *ipc = ap->cs.p_code.TrueCodeOfPred;
6098 UInt current_arity = 0;
6099
6100 if (ap->cs.p_code.NOfClauses == 1) {
6101 if (ap->PredFlags & IndexedPredFlag) {
6102 Yap_RemoveIndexation(ap);
6103 return;
6104 }
6105 ap->cs.p_code.TrueCodeOfPred = ap->cs.p_code.FirstClause;
6106 if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
6107 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
6108 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
6109 #if defined(YAPOR) || defined(THREADS)
6110 } else if (ap->PredFlags & LogUpdatePredFlag &&
6111 ap->ModuleOfPred != IDB_MODULE) {
6112 ap->cs.p_code.TrueCodeOfPred = FAILCODE;
6113 ap->OpcodeOfPred = LOCKPRED_OPCODE;
6114 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
6115 #endif
6116 } else {
6117 ap->OpcodeOfPred = ap->cs.p_code.FirstClause->opc;
6118 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
6119 }
6120 return;
6121 }
6122 sp = init_block_stack(sp, ipc, ap);
6123 /* try to refine the interval using the indexing code */
6124 while (ipc != NULL) {
6125 op_numbers op = Yap_op_from_opcode(ipc->opc);
6126
6127 switch(op) {
6128 case _retry_profiled:
6129 case _count_retry:
6130 ipc = NEXTOP(ipc, p);
6131 break;
6132 case _try_in:
6133 /* I cannot expand a predicate that starts on a variable,
6134 have to expand the index.
6135 */
6136 if (IN_BETWEEN(bg,ipc->u.l.l,lt)) {
6137 sp = kill_clause(ipc, bg, lt, sp, ap);
6138 ipc = pop_path(&sp, cls, ap, cint);
6139 } else {
6140 /* just go to next instruction */
6141 ipc = NEXTOP(ipc,l);
6142 }
6143 break;
6144 case _try_clause:
6145 case _retry:
6146 /* I cannot expand a predicate that starts on a variable,
6147 have to expand the index.
6148 */
6149 if (IN_BETWEEN(bg,ipc->u.Otapl.d,lt)) {
6150 sp = kill_clause(ipc, bg, lt, sp, ap);
6151 ipc = pop_path(&sp, cls, ap, cint);
6152 } else {
6153 /* just go to next instruction */
6154 ipc = NEXTOP(ipc,Otapl);
6155 }
6156 break;
6157 case _try_clause2:
6158 case _try_clause3:
6159 case _try_clause4:
6160 case _retry2:
6161 case _retry3:
6162 case _retry4:
6163 /* I cannot expand a predicate that starts on a variable,
6164 have to expand the index.
6165 */
6166 if (IN_BETWEEN(bg,ipc->u.l.l,lt)) {
6167 sp = kill_clause(ipc, bg, lt, sp, ap);
6168 ipc = pop_path(&sp, cls, ap, cint);
6169 } else {
6170 /* just go to next instruction */
6171 ipc = NEXTOP(ipc,l);
6172 }
6173 break;
6174 case _trust:
6175 if (IN_BETWEEN(bg,ipc->u.Otapl.d,lt)) {
6176 sp = kill_clause(ipc, bg, lt, sp, ap);
6177 }
6178 ipc = pop_path(&sp, cls, ap, cint);
6179 break;
6180 case _enter_lu_pred:
6181 ipc->u.Ills.s--;
6182 #ifdef DEBUG
6183 Yap_DirtyCps++;
6184 Yap_LiveCps--;
6185 #endif
6186 sp = kill_clause(ipc, bg, lt, sp, ap);
6187 ipc = pop_path(&sp, cls, ap, cint);
6188 break;
6189 /* instructions type l */
6190 case _try_me:
6191 case _retry_me:
6192 sp = push_path(sp, &(ipc->u.Otapl.d), cls, cint);
6193 ipc = NEXTOP(ipc,Otapl);
6194 break;
6195 case _profiled_trust_me:
6196 case _trust_me:
6197 case _count_trust_me:
6198 ipc = NEXTOP(ipc,Otapl);
6199 break;
6200 case _jump:
6201 sp = cross_block(sp, &ipc->u.l.l, ap, cint);
6202 /* just skip for now, but should worry about memory management */
6203 ipc = ipc->u.l.l;
6204 break;
6205 case _jump_if_var:
6206 sp = push_path(sp, &(ipc->u.l.l), cls, cint);
6207 ipc = NEXTOP(ipc,l);
6208 break;
6209 case _jump_if_nonvar:
6210 sp = push_path(sp, &(ipc->u.xll.l2), cls, cint);
6211 sp = cross_block(sp, &ipc->u.xll.l1, ap, cint);
6212 ipc = ipc->u.xll.l1;
6213 break;
6214 case _user_switch:
6215 ipc = ipc->u.lp.l;
6216 break;
6217 /* instructions type e */
6218 case _switch_on_type:
6219 sp = push_path(sp, &(ipc->u.llll.l4), cls, cint);
6220 if (ap->PredFlags & LogUpdatePredFlag) {
6221 add_head_info(cls, 1);
6222 } else {
6223 add_info(cls, 1);
6224 }
6225 if (IsPairTerm(cls->Tag)) {
6226 yamop *nipc = ipc->u.llll.l1;
6227 current_arity = 2;
6228 if (IN_BETWEEN(bg,nipc,lt)) {
6229 /* jump straight to clause */
6230 ipc->u.llll.l1 = FAILCODE;
6231 ipc = pop_path(&sp, cls, ap, cint);
6232 } else {
6233 /* go on */
6234 sp = cross_block(sp, &ipc->u.llll.l1, ap, cint);
6235 ipc = nipc;
6236 }
6237 } else if (IsAtomOrIntTerm(cls->Tag)) {
6238 yamop *nipc = ipc->u.llll.l2;
6239 if (IN_BETWEEN(bg,nipc,lt)) {
6240 /* jump straight to clause */
6241 ipc->u.llll.l2 = FAILCODE;
6242 ipc = pop_path(&sp, cls, ap, cint);
6243 } else {
6244 /* I do not have to worry about crossing a block here */
6245 ipc = nipc;
6246 }
6247 } else if (IsApplTerm(cls->Tag)) {
6248 yamop *nipc = ipc->u.llll.l3;
6249 if (IN_BETWEEN(bg,nipc,lt)) {
6250 /* jump straight to clause */
6251 ipc->u.llll.l3 = FAILCODE;
6252 ipc = pop_path(&sp, cls, ap, cint);
6253 } else {
6254 /* I do not have to worry about crossing a block here */
6255 ipc = nipc;
6256 }
6257 } else {
6258 /* we can't separate into four groups,
6259 need to restart.
6260 */
6261 sp = kill_block(sp, ap);
6262 ipc = pop_path(&sp, cls, ap, cint);
6263 }
6264 break;
6265 case _switch_list_nl:
6266 sp = kill_block(sp, ap);
6267 ipc = pop_path(&sp, cls, ap, cint);
6268 break;
6269 case _switch_on_arg_type:
6270 sp = push_path(sp, &(ipc->u.xllll.l4), cls, cint);
6271 current_arity = 2;
6272 if (ap->PredFlags & LogUpdatePredFlag) {
6273 add_head_info(cls, Yap_regtoregno(ipc->u.xllll.x));
6274 } else {
6275 add_info(cls, Yap_regtoregno(ipc->u.xllll.x));
6276 }
6277 if (IsPairTerm(cls->Tag)) {
6278 yamop *nipc = ipc->u.xllll.l1;
6279 if (IN_BETWEEN(bg,nipc,lt)) {
6280 /* jump straight to clause */
6281 ipc->u.xllll.l1 = FAILCODE;
6282 ipc = pop_path(&sp, cls, ap, cint);
6283 } else {
6284 /* go on */
6285 sp = cross_block(sp, &ipc->u.xllll.l1, ap, cint);
6286 ipc = nipc;
6287 }
6288 } else if (IsAtomOrIntTerm(cls->Tag)) {
6289 yamop *nipc = ipc->u.xllll.l2;
6290 if (IN_BETWEEN(bg,nipc,lt)) {
6291 /* jump straight to clause */
6292 ipc->u.xllll.l2 = FAILCODE;
6293 ipc = pop_path(&sp, cls, ap, cint);
6294 } else {
6295 /* I do not have to worry about crossing a block here */
6296 ipc = nipc;
6297 }
6298 } else if (IsApplTerm(cls->Tag)) {
6299 yamop *nipc = ipc->u.xllll.l3;
6300 if (IN_BETWEEN(bg,nipc,lt)) {
6301 /* jump straight to clause */
6302 ipc->u.xllll.l3 = FAILCODE;
6303 ipc = pop_path(&sp, cls, ap, cint);
6304 } else {
6305 /* I do not have to worry about crossing a block here */
6306 ipc = nipc;
6307 }
6308 } else {
6309 /* we can't separate into four groups,
6310 need to restart.
6311 */
6312 sp = kill_block(sp, ap);
6313 ipc = pop_path(&sp, cls, ap, cint);
6314 }
6315 break;
6316 case _switch_on_sub_arg_type:
6317 sp = push_path(sp, &(ipc->u.sllll.l4), cls, cint);
6318 current_arity = 2;
6319 add_arg_info(cls, ap, ipc->u.sllll.s+1);
6320 if (IsPairTerm(cls->Tag)) {
6321 yamop *nipc = ipc->u.sllll.l1;
6322 if (IN_BETWEEN(bg,nipc,lt)) {
6323 /* jump straight to clause */
6324 ipc->u.sllll.l1 = FAILCODE;
6325 ipc = pop_path(&sp, cls, ap, cint);
6326 } else {
6327 /* go on */
6328 sp = cross_block(sp, &ipc->u.sllll.l1, ap, cint);
6329 ipc = nipc;
6330 }
6331 } else if (IsAtomOrIntTerm(cls->Tag)) {
6332 yamop *nipc = ipc->u.sllll.l2;
6333 if (IN_BETWEEN(bg,nipc,lt)) {
6334 /* jump straight to clause */
6335 ipc->u.sllll.l2 = FAILCODE;
6336 ipc = pop_path(&sp, cls, ap, cint);
6337 } else {
6338 /* I do not have to worry about crossing a block here */
6339 ipc = nipc;
6340 }
6341 } else if (IsApplTerm(cls->Tag)) {
6342 yamop *nipc = ipc->u.sllll.l3;
6343 if (IN_BETWEEN(bg,nipc,lt)) {
6344 /* jump straight to clause */
6345 ipc->u.sllll.l3 = FAILCODE;
6346 ipc = pop_path(&sp, cls, ap, cint);
6347 } else {
6348 /* I do not have to worry about crossing a block here */
6349 ipc = nipc;
6350 }
6351 } else {
6352 /* we can't separate into four groups,
6353 need to restart.
6354 */
6355 sp = kill_block(sp, ap);
6356 ipc = pop_path(&sp, cls, ap, cint);
6357 }
6358 break;
6359 case _if_not_then:
6360 ipc = pop_path(&sp, cls, ap, cint);
6361 break;
6362 /* instructions type ollll */
6363 case _switch_on_func:
6364 case _if_func:
6365 case _go_on_func:
6366 {
6367 FuncSwiEntry *fe;
6368 yamop *newpc;
6369 Functor f = (Functor)RepAppl(cls->Tag);
6370
6371 if (op == _switch_on_func) {
6372 fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s);
6373 } else {
6374 fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s);
6375 }
6376 if (!IsExtensionFunctor(f)) {
6377 current_arity = ArityOfFunctor(f);
6378 }
6379 newpc = fe->u.labp;
6380
6381 if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) {
6382 /* we found it */
6383 ipc = pop_path(&sp, cls, ap, cint);
6384 } else if (newpc == FAILCODE) {
6385 ipc = pop_path(&sp, cls, ap, cint);
6386 } else if (IN_BETWEEN(bg,fe->u.Label,lt)) {
6387 /* oops, nothing there */
6388 contract_ftable(ipc, current_block(sp), ap, f);
6389 ipc = pop_path(&sp, cls, ap, cint);
6390 } else {
6391 yamop *newpc = fe->u.labp;
6392 sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint);
6393 sp = cross_block(sp, &(fe->u.labp), ap, cint);
6394 ipc = newpc;
6395 }
6396 }
6397 break;
6398 case _index_dbref:
6399 cls->Tag = cls->u.t_ptr;
6400 ipc = NEXTOP(ipc,e);
6401 break;
6402 case _index_blob:
6403 cls->Tag = Yap_Double_key(cls->u.t_ptr);
6404 ipc = NEXTOP(ipc,e);
6405 break;
6406 case _index_long:
6407 cls->Tag = Yap_Int_key(cls->u.t_ptr);
6408 ipc = NEXTOP(ipc,e);
6409 break;
6410 case _switch_on_cons:
6411 case _if_cons:
6412 case _go_on_cons:
6413 {
6414 AtomSwiEntry *ae;
6415 yamop *newpc;
6416 Term at = cls->Tag;
6417
6418 if (op == _switch_on_cons) {
6419 ae = lookup_c_hash(at,ipc->u.sssl.l,ipc->u.sssl.s);
6420 } else {
6421 ae = lookup_c(at, ipc->u.sssl.l, ipc->u.sssl.s);
6422 }
6423 newpc = ae->u.labp;
6424
6425 if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) {
6426 /* we found it */
6427 ipc = pop_path(&sp, cls, ap, cint);
6428 } else if (newpc == FAILCODE) {
6429 ipc = pop_path(&sp, cls, ap, cint);
6430 } else if (IN_BETWEEN(bg,ae->u.Label,lt)) {
6431 /* oops, nothing there */
6432 contract_ctable(ipc, current_block(sp), ap, at);
6433 ipc = pop_path(&sp, cls, ap, cint);
6434 } else {
6435 yamop *newpc = ae->u.labp;
6436
6437 sp = fetch_new_block(sp, &(ipc->u.sssl.l), ap, cint);
6438 sp = cross_block(sp, &(ae->u.labp), ap, cint);
6439 ipc = newpc;
6440 }
6441 }
6442 break;
6443 case _expand_index:
6444 ipc = pop_path(&sp, cls, ap, cint);
6445 break;
6446 case _expand_clauses:
6447 nullify_expand_clause(ipc, sp, cls);
6448 ipc = pop_path(&sp, cls, ap, cint);
6449 break;
6450 case _lock_lu:
6451 ipc = NEXTOP(ipc,p);
6452 break;
6453 default:
6454 if (IN_BETWEEN(bg,ipc,lt)) {
6455 sp = kill_unsafe_block(sp, op, ap, TRUE, TRUE, cls);
6456 }
6457 ipc = pop_path(&sp, cls, ap, cint);
6458 }
6459 }
6460 }
6461
6462
6463 /* clause is locked */
6464 void
Yap_RemoveClauseFromIndex(PredEntry * ap,yamop * beg)6465 Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) {
6466 ClauseDef cl;
6467 /* first clause */
6468 path_stack_entry *stack, *sp;
6469 int cb;
6470 yamop *last;
6471 struct intermediates cint;
6472
6473 if (ap->PredFlags & MegaClausePredFlag) {
6474 return;
6475 }
6476 cint.expand_block = NULL;
6477 cint.CodeStart = cint.BlobsStart = cint.cpc = cint.icpc = NULL;
6478 if ((cb = sigsetjmp(cint.CompilerBotch, 0)) == 3) {
6479 restore_machine_regs();
6480 Yap_gcl(Yap_Error_Size, ap->ArityOfPE, ENV, CP);
6481 save_machine_regs();
6482 } else if (cb == 2) {
6483 restore_machine_regs();
6484 Yap_growheap(FALSE, Yap_Error_Size, NULL);
6485 save_machine_regs();
6486 } else if (cb == 4) {
6487 restore_machine_regs();
6488 Yap_growtrail(Yap_Error_Size, FALSE);
6489 save_machine_regs();
6490 }
6491 Yap_Error_Size = 0;
6492 Yap_ErrorMessage = NULL;
6493 if (cb) {
6494 /* cannot rely on the code */
6495 if (ap->PredFlags & LogUpdatePredFlag) {
6496 Yap_kill_iblock((ClauseUnion *)ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap);
6497 } else {
6498 StaticIndex *cl;
6499
6500 cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
6501 Yap_kill_iblock((ClauseUnion *)cl, NULL, ap);
6502 }
6503 return;
6504 }
6505 #ifdef DEBUG
6506 if (Yap_Option['i' - 'a' + 1]) {
6507 Term tmod = ap->ModuleOfPred;
6508
6509 if (!tmod) tmod = TermProlog;
6510 Yap_LockStream(Yap_c_error_stream);
6511 Yap_DebugPutc(Yap_c_error_stream,'-');
6512 Yap_DebugPutc(Yap_c_error_stream,'\t');
6513 Yap_DebugPlWrite(tmod);
6514 Yap_DebugPutc(Yap_c_error_stream,':');
6515 if (ap->ModuleOfPred != IDB_MODULE) {
6516 if (ap->ArityOfPE == 0) {
6517 Atom At = (Atom)ap->FunctorOfPred;
6518 Yap_DebugPlWrite(MkAtomTerm(At));
6519 } else {
6520 Functor f = ap->FunctorOfPred;
6521 Atom At = NameOfFunctor(f);
6522 Yap_DebugPlWrite(MkAtomTerm(At));
6523 Yap_DebugPutc(Yap_c_error_stream,'/');
6524 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
6525 }
6526 } else {
6527 if (ap->PredFlags & NumberDBPredFlag) {
6528 Int id = ap->src.IndxId;
6529 Yap_DebugPlWrite(MkIntegerTerm(id));
6530 } else if (ap->PredFlags & AtomDBPredFlag) {
6531 Atom At = (Atom)ap->FunctorOfPred;
6532 Yap_DebugPlWrite(MkAtomTerm(At));
6533 } else {
6534 Functor f = ap->FunctorOfPred;
6535 Atom At = NameOfFunctor(f);
6536 Yap_DebugPlWrite(MkAtomTerm(At));
6537 Yap_DebugPutc(Yap_c_error_stream,'/');
6538 Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
6539 }
6540 }
6541 Yap_DebugPutc(Yap_c_error_stream,'\n');
6542 Yap_UnLockStream(Yap_c_error_stream);
6543 }
6544 #endif
6545 stack = (path_stack_entry *)TR;
6546 if (ap->PredFlags & LogUpdatePredFlag) {
6547 LogUpdClause *c = ClauseCodeToLogUpdClause(beg);
6548 cl.Code = cl.CurrentCode = beg;
6549 last = (yamop *)((CODEADDR)c+c->ClSize);
6550 } else {
6551 StaticClause *c = ClauseCodeToStaticClause(beg);
6552 cl.Code = cl.CurrentCode = beg;
6553 last = (yamop *)((CODEADDR)c+c->ClSize);
6554 }
6555 sp = push_path(stack, NULL, &cl, &cint);
6556 if (ap->cs.p_code.NOfClauses == 0) {
6557 /* there was no indexing code */
6558 #if defined(YAPOR) || defined(THREADS)
6559 if (ap->PredFlags & LogUpdatePredFlag &&
6560 ap->ModuleOfPred != IDB_MODULE) {
6561 ap->cs.p_code.TrueCodeOfPred = FAILCODE;
6562 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
6563 } else {
6564 #endif
6565 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = FAILCODE;
6566 #if defined(YAPOR) || defined(THREADS)
6567 }
6568 #endif
6569 ap->OpcodeOfPred = Yap_opcode(_op_fail);
6570 } else {
6571 remove_from_index(ap, sp, &cl, beg, last, &cint);
6572 }
6573 }
6574
6575
6576 static void
store_clause_choice_point(Term t1,Term tb,Term tr,yamop * ipc,PredEntry * pe,yamop * ap_pc,yamop * cp_pc)6577 store_clause_choice_point(Term t1, Term tb, Term tr, yamop *ipc, PredEntry *pe, yamop *ap_pc, yamop *cp_pc)
6578 {
6579 Term tpc = MkIntegerTerm((Int)ipc);
6580 Term tpe = MkIntegerTerm((Int)pe);
6581 CELL *tsp = ASP-5;
6582 choiceptr bptr = ((choiceptr)tsp)-1;
6583
6584 tsp[0] = tpe;
6585 tsp[1] = tpc;
6586 tsp[2] = t1;
6587 tsp[3] = tb;
6588 tsp[4] = tr;
6589 bptr->cp_tr = TR;
6590 HB = bptr->cp_h = H;
6591 #ifdef DEPTH_LIMIT
6592 bptr->cp_depth = DEPTH;
6593 #endif
6594 bptr->cp_b = B;
6595 bptr->cp_cp = cp_pc;
6596 bptr->cp_ap = ap_pc;
6597 bptr->cp_env = ENV;
6598 /* now, install the new YREG */
6599 ASP = (CELL *)bptr;
6600 ASP[E_CB] = (CELL)bptr;
6601 B = bptr;
6602 #ifdef YAPOR
6603 SCH_set_load(B);
6604 #endif /* YAPOR */
6605 SET_BB(bptr);
6606 }
6607
6608 static void
update_clause_choice_point(yamop * ipc,yamop * ap_pc)6609 update_clause_choice_point(yamop *ipc, yamop *ap_pc)
6610 {
6611 Term tpc = MkIntegerTerm((Int)ipc);
6612 B->cp_args[1] = tpc;
6613 B->cp_h = H;
6614 B->cp_ap = ap_pc;
6615 }
6616
6617 static LogUpdClause *
to_clause(yamop * ipc,PredEntry * ap)6618 to_clause(yamop *ipc, PredEntry *ap)
6619 {
6620 if (ap->PredFlags & LogUpdatePredFlag)
6621 return lu_clause(ipc, ap);
6622 else if (ap->PredFlags & MegaClausePredFlag)
6623 return (LogUpdClause *)ipc;
6624 else
6625 return (LogUpdClause *)simple_static_clause(ipc, ap);
6626 }
6627
6628 LogUpdClause *
Yap_FollowIndexingCode(PredEntry * ap,yamop * ipc,Term Terms[3],yamop * ap_pc,yamop * cp_pc)6629 Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, yamop *cp_pc)
6630 {
6631 CELL *s_reg = NULL;
6632 Term t = TermNil;
6633 yamop *start_pc = ipc;
6634 choiceptr b0 = NULL;
6635 yamop **jlbl = NULL;
6636 int lu_pred = ap->PredFlags & LogUpdatePredFlag;
6637 int unbounded = TRUE;
6638
6639 if (ap->ModuleOfPred != IDB_MODULE) {
6640 if (ap->ArityOfPE) {
6641 CELL *tar = RepAppl(Deref(Terms[0]));
6642 UInt i;
6643
6644 for (i = 1; i <= ap->ArityOfPE; i++) {
6645 XREGS[i] = tar[i];
6646 }
6647 }
6648 }
6649 /* try to refine the interval using the indexing code */
6650 while (ipc != NULL) {
6651 op_numbers op = Yap_op_from_opcode(ipc->opc);
6652 switch(op) {
6653 case _try_in:
6654 update_clause_choice_point(NEXTOP(ipc,l), ap_pc);
6655 if (lu_pred)
6656 return lu_clause(ipc->u.l.l, ap);
6657 else
6658 return (LogUpdClause *)static_clause(ipc->u.l.l, ap, unbounded);
6659 break;
6660 case _try_clause:
6661 #if TABLING
6662 case _table_try:
6663 #endif
6664 if (b0 == NULL)
6665 store_clause_choice_point(Terms[0], Terms[1], Terms[2], NEXTOP(ipc,Otapl), ap, ap_pc, cp_pc);
6666 else {
6667 B = b0;
6668 b0 = NULL;
6669 update_clause_choice_point(NEXTOP(ipc,Otapl), ap_pc);
6670 }
6671 if (lu_pred)
6672 return lu_clause(ipc->u.Otapl.d, ap);
6673 else
6674 return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, unbounded);
6675 case _try_clause2:
6676 case _try_clause3:
6677 case _try_clause4:
6678 if (b0 == NULL)
6679 store_clause_choice_point(Terms[0], Terms[1], Terms[2], NEXTOP(ipc,l), ap, ap_pc, cp_pc);
6680 else {
6681 B = b0;
6682 b0 = NULL;
6683 update_clause_choice_point(NEXTOP(ipc,l), ap_pc);
6684 }
6685 if (lu_pred)
6686 return lu_clause(ipc->u.l.l, ap);
6687 else
6688 return (LogUpdClause *)static_clause(ipc->u.l.l, ap, unbounded);
6689 case _try_me:
6690 #if TABLING
6691 case _table_try_me:
6692 #endif
6693 if (b0 == NULL)
6694 store_clause_choice_point(Terms[0], Terms[1], Terms[2], ipc->u.Otapl.d, ap, ap_pc, cp_pc);
6695 else {
6696 B = b0;
6697 b0 = NULL;
6698 update_clause_choice_point(ipc->u.Otapl.d, ap_pc);
6699 }
6700 ipc = NEXTOP(ipc,Otapl);
6701 break;
6702 case _retry_profiled:
6703 case _count_retry:
6704 ipc = NEXTOP(ipc,p);
6705 break;
6706 case _retry:
6707 #if TABLING
6708 case _table_retry:
6709 #endif
6710 update_clause_choice_point(NEXTOP(ipc,Otapl),ap_pc);
6711 if (lu_pred)
6712 return lu_clause(ipc->u.Otapl.d, ap);
6713 else
6714 return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, TRUE);
6715 case _retry2:
6716 case _retry3:
6717 case _retry4:
6718 update_clause_choice_point(NEXTOP(ipc,l),ap_pc);
6719 if (lu_pred)
6720 return lu_clause(ipc->u.l.l, ap);
6721 else
6722 return (LogUpdClause *)static_clause(ipc->u.l.l, ap, TRUE);
6723 case _retry_me:
6724 update_clause_choice_point(ipc->u.Otapl.d,ap_pc);
6725 ipc = NEXTOP(ipc,Otapl);
6726 break;
6727 case _trust:
6728 #if TABLING
6729 case _table_trust:
6730 #endif
6731 #ifdef CUT_C
6732 {
6733 while (POP_CHOICE_POINT(B->cp_b))
6734 {
6735 POP_EXECUTE();
6736 }
6737 }
6738 #endif /* CUT_C */
6739 #ifdef YAPOR
6740 {
6741 choiceptr cut_pt;
6742 cut_pt = B->cp_b;
6743 CUT_prune_to(cut_pt);
6744 B = cut_pt;
6745 }
6746 #else
6747 B = B->cp_b;
6748 #endif /* YAPOR */
6749 b0 = B;
6750 if (lu_pred)
6751 return lu_clause(ipc->u.Otapl.d, ap);
6752 else
6753 return (LogUpdClause *)static_clause(ipc->u.Otapl.d, ap, TRUE);
6754 case _profiled_trust_me:
6755 case _trust_me:
6756 case _count_trust_me:
6757 #if TABLING
6758 case _table_trust_me:
6759 #endif
6760 b0 = B;
6761 #ifdef CUT_C
6762 {
6763 while (POP_CHOICE_POINT(B->cp_b))
6764 {
6765 POP_EXECUTE();
6766 }
6767 }
6768 #endif /* CUT_C */
6769 #ifdef YAPOR
6770 {
6771 choiceptr cut_pt;
6772 cut_pt = B->cp_b;
6773 CUT_prune_to(cut_pt);
6774 B = cut_pt;
6775 }
6776 #else
6777 B = B->cp_b;
6778 #endif /* YAPOR */
6779 ipc = NEXTOP(ipc,Otapl);
6780 break;
6781 case _enter_lu_pred:
6782 {
6783 LogUpdIndex *cl = ipc->u.Ills.I;
6784 PredEntry *ap = cl->ClPred;
6785
6786 if (ap->LastCallOfPred != LUCALL_EXEC) {
6787 /*
6788 only increment time stamp if we are working on current time
6789 stamp
6790 */
6791 if (ap->TimeStampOfPred >= TIMESTAMP_RESET)
6792 Yap_UpdateTimestamps(ap);
6793 ap->TimeStampOfPred++;
6794 /* fprintf(stderr,"R %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
6795 ap->LastCallOfPred = LUCALL_EXEC;
6796 }
6797 *--ASP = MkIntegerTerm(ap->TimeStampOfPred);
6798 /* indicate the indexing code is being used */
6799 #if defined(YAPOR) || defined(THREADS)
6800 /* just store a reference */
6801 INC_CLREF_COUNT(cl);
6802 TRAIL_CLREF(cl);
6803 #else
6804 if (!(cl->ClFlags & InUseMask)) {
6805 cl->ClFlags |= InUseMask;
6806 TRAIL_CLREF(cl);
6807 }
6808 #endif
6809 }
6810 ipc = ipc->u.Ills.l1;
6811 break;
6812 case _try_logical:
6813 if (b0 == NULL)
6814 store_clause_choice_point(Terms[0], Terms[1], Terms[2], ipc->u.OtaLl.n, ap, ap_pc, cp_pc);
6815 else {
6816 B = b0;
6817 b0 = NULL;
6818 update_clause_choice_point(ipc->u.OtaLl.n, ap_pc);
6819 }
6820 {
6821 UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
6822
6823 if (!VALID_TIMESTAMP(timestamp, ipc->u.OtaLl.d)) {
6824 /* jump to next instruction */
6825 ipc = ipc->u.OtaLl.n;
6826 break;
6827 }
6828 }
6829 return ipc->u.OtaLl.d;
6830 case _retry_logical:
6831 case _profiled_retry_logical:
6832 case _count_retry_logical:
6833 {
6834 UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
6835 if (!VALID_TIMESTAMP(timestamp, ipc->u.OtaLl.d)) {
6836 /* jump to next instruction */
6837 ipc = ipc->u.OtaLl.n;
6838 break;
6839 }
6840 }
6841 update_clause_choice_point(ipc->u.OtILl.n,ap_pc);
6842 return ipc->u.OtILl.d;
6843 #if TABLING
6844 case _table_try_single:
6845 return (LogUpdClause *)ClauseCodeToStaticClause(ipc);
6846 #endif
6847 case _trust_logical:
6848 case _count_trust_logical:
6849 case _profiled_trust_logical:
6850 {
6851 UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
6852 LogUpdIndex *cl = ipc->u.OtILl.block;
6853 LogUpdClause *newpc;
6854
6855 if (!VALID_TIMESTAMP(timestamp, ipc->u.OtILl.d)) {
6856 /* jump to next instruction */
6857 newpc = NULL;
6858 } else {
6859 newpc = ipc->u.OtILl.d;
6860 }
6861 #if defined(YAPOR) || defined(THREADS)
6862 B->cp_tr--;
6863 TR--;
6864 DEC_CLREF_COUNT(cl);
6865 /* actually get rid of the code */
6866 if (cl->ClRefCount == 0 && cl->ClFlags & (ErasedMask|DirtyMask)) {
6867 /* I am the last one using this clause, hence I don't need a lock
6868 to dispose of it
6869 */
6870 if (cl->ClFlags & ErasedMask) {
6871 Yap_ErLogUpdIndex(cl);
6872 } else {
6873 Yap_CleanUpIndex(cl);
6874 }
6875 }
6876 #else
6877 if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
6878 B->cp_tr != B->cp_b->cp_tr) {
6879
6880 B->cp_tr--;
6881 TR--;
6882 cl->ClFlags &= ~InUseMask;
6883 /* next, recover space for the indexing code if it was erased */
6884 if (cl->ClFlags & (ErasedMask|DirtyMask)) {
6885 LogUpdClause *lcl = ipc->u.OtILl.d;
6886 /* make sure we don't erase the clause we are jumping to */
6887 if (lcl->ClRefCount == 1 && !(lcl->ClFlags & (DirtyMask|InUseMask))) {
6888 lcl->ClFlags |= InUseMask;
6889 TRAIL_CLREF(lcl);
6890 }
6891 if (cl->ClFlags & ErasedMask) {
6892 Yap_ErLogUpdIndex(cl);
6893 } else {
6894 Yap_CleanUpIndex(cl);
6895 }
6896 }
6897 }
6898 #endif
6899 #ifdef CUT_C
6900 {
6901 while (POP_CHOICE_POINT(B->cp_b))
6902 {
6903 POP_EXECUTE();
6904 }
6905 }
6906 #endif /* CUT_C */
6907 #ifdef YAPOR
6908 {
6909 choiceptr cut_pt;
6910 cut_pt = B->cp_b;
6911 CUT_prune_to(cut_pt);
6912 B = cut_pt;
6913 }
6914 #else
6915 B = B->cp_b;
6916 #endif /* YAPOR */
6917 b0 = B;
6918 return newpc;
6919 }
6920 case _jump:
6921 ipc = ipc->u.l.l;
6922 break;
6923 case _jump_if_var:
6924 {
6925 Term t = Deref(ARG1);
6926 if (IsVarTerm(t)) {
6927 jlbl = &(ipc->u.l.l);
6928 ipc = ipc->u.l.l;
6929 } else {
6930 ipc = NEXTOP(ipc,l);
6931 }
6932 }
6933 break;
6934 case _jump_if_nonvar:
6935 {
6936 Term t = Deref(XREGS[arg_from_x(ipc->u.xll.x)]);
6937 if (!IsVarTerm(t)) {
6938 jlbl = &(ipc->u.xll.l1);
6939 ipc = ipc->u.xll.l1;
6940 } else {
6941 ipc = NEXTOP(ipc,xll);
6942 }
6943 }
6944 break;
6945 case _user_switch:
6946 ipc = ipc->u.lp.l;
6947 break;
6948 /* instructions type e */
6949 case _switch_on_type:
6950 t = Deref(ARG1);
6951 if (IsVarTerm(t)) {
6952 jlbl = &(ipc->u.llll.l4);
6953 ipc = ipc->u.llll.l4;
6954 } else if (IsPairTerm(t)) {
6955 unbounded = FALSE;
6956 jlbl = &(ipc->u.llll.l1);
6957 ipc = ipc->u.llll.l1;
6958 S = s_reg = RepPair(t);
6959 } else if (IsAtomOrIntTerm(t)) {
6960 jlbl = &(ipc->u.llll.l2);
6961 ipc = ipc->u.llll.l2;
6962 } else {
6963 jlbl = &(ipc->u.llll.l3);
6964 ipc = ipc->u.llll.l3;
6965 S = RepAppl(t);
6966 }
6967 break;
6968 case _switch_list_nl:
6969 t = Deref(ARG1);
6970 if (IsVarTerm(t)) {
6971 jlbl = &(ipc->u.ollll.l4);
6972 ipc = ipc->u.ollll.l4;
6973 } else if (IsPairTerm(t)) {
6974 unbounded = FALSE;
6975 jlbl = &(ipc->u.ollll.l1);
6976 ipc = ipc->u.ollll.l1;
6977 S = s_reg = RepPair(t);
6978 } else if (t == TermNil) {
6979 unbounded = FALSE;
6980 jlbl = &(ipc->u.ollll.l2);
6981 ipc = ipc->u.ollll.l2;
6982 } else {
6983 jlbl = &(ipc->u.ollll.l3);
6984 ipc = ipc->u.ollll.l3;
6985 S = RepAppl(t);
6986 }
6987 break;
6988 case _switch_on_arg_type:
6989 t = Deref(XREGS[arg_from_x(ipc->u.xllll.x)]);
6990 if (IsVarTerm(t)) {
6991 jlbl = &(ipc->u.xllll.l4);
6992 ipc = ipc->u.xllll.l4;
6993 } else if (IsPairTerm(t)) {
6994 unbounded = FALSE;
6995 jlbl = &(ipc->u.xllll.l1);
6996 ipc = ipc->u.xllll.l1;
6997 S = s_reg = RepPair(t);
6998 } else if (IsAtomOrIntTerm(t)) {
6999 jlbl = &(ipc->u.xllll.l1);
7000 ipc = ipc->u.xllll.l2;
7001 } else {
7002 jlbl = &(ipc->u.xllll.l3);
7003 ipc = ipc->u.xllll.l3;
7004 S = RepAppl(t);
7005 }
7006 break;
7007 case _switch_on_sub_arg_type:
7008 t = Deref(s_reg[ipc->u.sllll.s]);
7009 if (IsVarTerm(t)) {
7010 jlbl = &(ipc->u.sllll.l4);
7011 ipc = ipc->u.sllll.l4;
7012 } else if (IsPairTerm(t)) {
7013 unbounded = FALSE;
7014 jlbl = &(ipc->u.sllll.l1);
7015 ipc = ipc->u.sllll.l1;
7016 S = s_reg = RepPair(t);
7017 } else if (IsAtomOrIntTerm(t)) {
7018 jlbl = &(ipc->u.sllll.l2);
7019 ipc = ipc->u.sllll.l2;
7020 } else {
7021 jlbl = &(ipc->u.sllll.l3);
7022 ipc = ipc->u.sllll.l3;
7023 S = RepAppl(t);
7024 }
7025 break;
7026 case _if_not_then:
7027 t = Deref(ARG1);
7028 if (IsVarTerm(t)) {
7029 jlbl = &(ipc->u.clll.l3);
7030 ipc = ipc->u.clll.l3;
7031 } else if (!IsVarTerm(t) && t != ipc->u.clll.c) {
7032 jlbl = &(ipc->u.clll.l1);
7033 ipc = ipc->u.clll.l1;
7034 } else {
7035 jlbl = &(ipc->u.clll.l2);
7036 ipc = ipc->u.clll.l2;
7037 }
7038 break;
7039 /* instructions type ollll */
7040 case _switch_on_func:
7041 case _if_func:
7042 case _go_on_func:
7043 {
7044 FuncSwiEntry *fe;
7045 Functor f;
7046
7047 unbounded = FALSE;
7048 s_reg = RepAppl(t);
7049 f = (Functor)s_reg[0];
7050 s_reg++;
7051 S = s_reg;
7052 if (op == _switch_on_func) {
7053 fe = lookup_f_hash(f, ipc->u.sssl.l, ipc->u.sssl.s);
7054 } else {
7055 fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s);
7056 }
7057 jlbl = &(fe->u.labp);
7058 ipc = fe->u.labp;
7059 }
7060 break;
7061 case _index_dbref:
7062 t = AbsAppl(s_reg-1);
7063 ipc = NEXTOP(ipc,e);
7064 break;
7065 case _index_blob:
7066 t = Yap_DoubleP_key(s_reg);
7067 ipc = NEXTOP(ipc,e);
7068 break;
7069 case _index_long:
7070 t = Yap_IntP_key(s_reg);
7071 ipc = NEXTOP(ipc,e);
7072 break;
7073 case _switch_on_cons:
7074 case _if_cons:
7075 case _go_on_cons:
7076 {
7077 AtomSwiEntry *ae;
7078
7079 unbounded = FALSE;
7080 if (op == _switch_on_cons) {
7081 ae = lookup_c_hash(t, ipc->u.sssl.l, ipc->u.sssl.s);
7082 } else {
7083 ae = lookup_c(t, ipc->u.sssl.l, ipc->u.sssl.s);
7084 }
7085 jlbl = &(ae->u.labp);
7086 ipc = ae->u.labp;
7087 }
7088 break;
7089 case _expand_index:
7090 case _expand_clauses:
7091 XREGS[ap->ArityOfPE+1] = (CELL)s_reg;
7092 XREGS[ap->ArityOfPE+2] = (CELL)t;
7093 XREGS[ap->ArityOfPE+3] = Terms[0];
7094 XREGS[ap->ArityOfPE+4] = Terms[1];
7095 XREGS[ap->ArityOfPE+5] = Terms[2];
7096 #if defined(YAPOR) || defined(THREADS)
7097 if (!same_lu_block(jlbl, ipc)) {
7098 ipc = *jlbl;
7099 break;
7100 }
7101 #endif
7102 ipc = ExpandIndex(ap, 5, cp_pc);
7103 s_reg = (CELL *)XREGS[ap->ArityOfPE+1];
7104 t = XREGS[ap->ArityOfPE+2];
7105 Terms[0] = XREGS[ap->ArityOfPE+3];
7106 Terms[1] = XREGS[ap->ArityOfPE+4];
7107 Terms[2] = XREGS[ap->ArityOfPE+5];
7108 break;
7109 case _undef_p:
7110 return NULL;
7111 case _lock_lu:
7112 ipc = NEXTOP(ipc,p);
7113 break;
7114 #if THREADS
7115 case _thread_local:
7116 ap = Yap_GetThreadPred(ap);
7117 ipc = ap->CodeOfPred;
7118 break;
7119 #endif
7120 case _spy_pred:
7121 case _lock_pred:
7122 if ((ap->PredFlags & IndexedPredFlag) ||
7123 ap->cs.p_code.NOfClauses <= 1) {
7124 ipc = ap->cs.p_code.TrueCodeOfPred;
7125 break;
7126 }
7127 case _index_pred:
7128 XREGS[ap->ArityOfPE+1] = (CELL)s_reg;
7129 XREGS[ap->ArityOfPE+2] = (CELL)t;
7130 XREGS[ap->ArityOfPE+3] = Terms[0];
7131 XREGS[ap->ArityOfPE+4] = Terms[1];
7132 XREGS[ap->ArityOfPE+5] = Terms[2];
7133 Yap_IPred(ap, 5, cp_pc);
7134 start_pc = ipc = ap->cs.p_code.TrueCodeOfPred;
7135 s_reg = (CELL *)XREGS[ap->ArityOfPE+1];
7136 t = XREGS[ap->ArityOfPE+2];
7137 Terms[0] = XREGS[ap->ArityOfPE+3];
7138 Terms[1] = XREGS[ap->ArityOfPE+4];
7139 Terms[2] = XREGS[ap->ArityOfPE+5];
7140 break;
7141 case _op_fail:
7142 if (ipc == FAILCODE)
7143 return NULL;
7144 default:
7145 if (b0) {
7146 #ifdef CUT_C
7147 {
7148 while (POP_CHOICE_POINT(B->cp_b))
7149 {
7150 POP_EXECUTE();
7151 }
7152 }
7153 #endif /* CUT_C */
7154 #ifdef YAPOR
7155 {
7156 choiceptr cut_pt;
7157 cut_pt = B->cp_b;
7158 CUT_prune_to(cut_pt);
7159 B = cut_pt;
7160 }
7161 #else
7162 B = B->cp_b;
7163 #endif /* YAPOR */
7164 /* I did a trust */
7165 }
7166 if (op == _op_fail)
7167 return NULL;
7168 if (lu_pred)
7169 return lu_clause(ipc, ap);
7170 else
7171 return (LogUpdClause *)static_clause(ipc, ap, unbounded);
7172 }
7173 }
7174 if (b0) {
7175 /* I did a trust */
7176 #ifdef CUT_C
7177 {
7178 while (POP_CHOICE_POINT(B->cp_b))
7179 {
7180 POP_EXECUTE();
7181 }
7182 }
7183 #endif /* CUT_C */
7184 #ifdef YAPOR
7185 {
7186 choiceptr cut_pt;
7187 cut_pt = B->cp_b;
7188 CUT_prune_to(cut_pt);
7189 B = cut_pt;
7190 }
7191 #else
7192 B = B->cp_b;
7193 #endif /* YAPOR */
7194 }
7195 return NULL;
7196 }
7197
7198 LogUpdClause *
Yap_NthClause(PredEntry * ap,Int ncls)7199 Yap_NthClause(PredEntry *ap, Int ncls)
7200 {
7201 yamop
7202 *ipc = ap->cs.p_code.TrueCodeOfPred,
7203 *alt = NULL;
7204 yamop **jlbl = NULL;
7205
7206 /* search every clause */
7207 if (ncls > ap->cs.p_code.NOfClauses)
7208 return NULL;
7209 else if (ncls == 1)
7210 return to_clause(ap->cs.p_code.FirstClause,ap);
7211 else if (ncls == ap->cs.p_code.NOfClauses)
7212 return to_clause(ap->cs.p_code.LastClause,ap);
7213 else if (ncls < 0)
7214 return NULL;
7215
7216 if (ap->ModuleOfPred != IDB_MODULE) {
7217 if (ap->ArityOfPE) {
7218 UInt i;
7219
7220 for (i = 1; i <= ap->ArityOfPE; i++) {
7221 XREGS[i] = MkVarTerm();
7222 }
7223 }
7224 } else {
7225 ARG2 = MkVarTerm();
7226 }
7227 while (TRUE) {
7228 op_numbers op = Yap_op_from_opcode(ipc->opc);
7229
7230 switch(op) {
7231 case _try_in:
7232 if (ncls == 1)
7233 return to_clause(ipc->u.l.l, ap);
7234 ncls--;
7235 ipc = NEXTOP(ipc,l);
7236 break;
7237 case _retry_profiled:
7238 case _count_retry:
7239 ipc = NEXTOP(ipc,p);
7240 case _try_clause:
7241 case _retry:
7242 if (ncls == 1)
7243 return to_clause(ipc->u.Otapl.d, ap);
7244 else if (alt == NULL) {
7245 ncls --;
7246 /* get there in a fell swoop */
7247 if (ap->PredFlags & ProfiledPredFlag) {
7248 if (ap->PredFlags & CountPredFlag) {
7249 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP(NEXTOP((yamop *)NULL,Otapl),p),p));
7250 } else {
7251 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,Otapl),p));
7252 }
7253 } else if (ap->PredFlags & CountPredFlag) {
7254 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,Otapl),p));
7255 } else {
7256 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP((yamop *)NULL,Otapl));
7257 }
7258 return to_clause(ipc->u.Otapl.d, ap);
7259 } else {
7260 ncls--;
7261 }
7262 ipc = NEXTOP(ipc,Otapl);
7263 break;
7264 case _try_clause2:
7265 case _try_clause3:
7266 case _try_clause4:
7267 case _retry2:
7268 case _retry3:
7269 case _retry4:
7270 if (ncls == 1)
7271 return to_clause(ipc->u.l.l, ap);
7272 else if (alt == NULL) {
7273 ncls --;
7274 /* get there in a fell swoop */
7275 if (ap->PredFlags & ProfiledPredFlag) {
7276 if (ap->PredFlags & CountPredFlag) {
7277 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP(NEXTOP((yamop *)NULL,l),p),p));
7278 } else {
7279 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,l),p));
7280 }
7281 } else if (ap->PredFlags & CountPredFlag) {
7282 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,l),p));
7283 } else {
7284 ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP((yamop *)NULL,l));
7285 }
7286 return to_clause(ipc->u.l.l, ap);
7287 } else {
7288 ncls--;
7289 }
7290 ipc = NEXTOP(ipc,l);
7291 break;
7292 case _trust:
7293 if (ncls == 1)
7294 return to_clause(ipc->u.l.l,ap);
7295 ncls--;
7296 ipc = alt;
7297 break;
7298 case _try_me:
7299 case _retry_me:
7300 alt = ipc->u.Otapl.d;
7301 ipc = NEXTOP(ipc,Otapl);
7302 break;
7303 case _profiled_trust_me:
7304 case _trust_me:
7305 case _count_trust_me:
7306 alt = NULL;
7307 ipc = NEXTOP(ipc,Otapl);
7308 break;
7309 case _try_logical:
7310 case _retry_logical:
7311 case _count_retry_logical:
7312 case _profiled_retry_logical:
7313 if (VALID_TIMESTAMP(ap->TimeStampOfPred, ipc->u.OtaLl.d)) {
7314 if (ncls == 1)
7315 return ipc->u.OtaLl.d;
7316 ncls--;
7317 }
7318 ipc = ipc->u.OtaLl.n;
7319 break;
7320 case _trust_logical:
7321 case _count_trust_logical:
7322 case _profiled_trust_logical:
7323 if (VALID_TIMESTAMP(ap->TimeStampOfPred, ipc->u.OtILl.d)) {
7324 if (ncls == 1)
7325 return ipc->u.OtILl.d;
7326 }
7327 return NULL;
7328 case _enter_lu_pred:
7329 ipc = ipc->u.Ills.l1;
7330 break;
7331 case _lock_lu:
7332 ipc = NEXTOP(ipc,p);
7333 break;
7334 case _jump:
7335 jlbl = &(ipc->u.l.l);
7336 ipc = ipc->u.l.l;
7337 break;
7338 case _jump_if_var:
7339 jlbl = &(ipc->u.l.l);
7340 ipc = ipc->u.l.l;
7341 break;
7342 case _jump_if_nonvar:
7343 ipc = NEXTOP(ipc,xll);
7344 break;
7345 case _user_switch:
7346 ipc = ipc->u.lp.l;
7347 break;
7348 /* instructions type e */
7349 case _switch_on_type:
7350 jlbl = &(ipc->u.llll.l4);
7351 ipc = ipc->u.llll.l4;
7352 break;
7353 case _switch_list_nl:
7354 jlbl = &(ipc->u.ollll.l4);
7355 ipc = ipc->u.ollll.l4;
7356 break;
7357 case _switch_on_arg_type:
7358 jlbl = &(ipc->u.xllll.l4);
7359 ipc = ipc->u.xllll.l4;
7360 break;
7361 case _switch_on_sub_arg_type:
7362 jlbl = &(ipc->u.sllll.l4);
7363 ipc = ipc->u.sllll.l4;
7364 break;
7365 case _if_not_then:
7366 jlbl = &(ipc->u.clll.l3);
7367 ipc = ipc->u.clll.l3;
7368 break;
7369 case _expand_index:
7370 case _expand_clauses:
7371 #if defined(YAPOR) || defined(THREADS)
7372 if (*jlbl != (yamop *)&(ap->cs.p_code.ExpandCode)) {
7373 ipc = *jlbl;
7374 break;
7375 }
7376 #endif
7377 ipc = ExpandIndex(ap, 0, CP);
7378
7379 break;
7380 case _op_fail:
7381 ipc = alt;
7382 break;
7383 case _lock_pred:
7384 case _index_pred:
7385 case _spy_pred:
7386 Yap_IPred(ap, 0, CP);
7387 ipc = ap->cs.p_code.TrueCodeOfPred;
7388 break;
7389 case _undef_p:
7390 default:
7391 return NULL;
7392 }
7393 }
7394 }
7395
7396 void
Yap_CleanUpIndex(LogUpdIndex * blk)7397 Yap_CleanUpIndex(LogUpdIndex *blk)
7398 {
7399 /* just compact the code */
7400 yamop *start = blk->ClCode, *codep;
7401 op_numbers op = Yap_op_from_opcode(start->opc);
7402
7403 blk->ClFlags &= ~DirtyMask;
7404 while (op == _lock_lu) {
7405 start = NEXTOP(start, p);
7406 op = Yap_op_from_opcode(start->opc);
7407 }
7408 while (op == _jump_if_nonvar) {
7409 start = NEXTOP(start, xll);
7410 op = Yap_op_from_opcode(start->opc);
7411 }
7412 codep = start->u.Ills.l1;
7413 remove_dirty_clauses_from_index(start);
7414 }
7415
7416