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: cdmgr.c *
12 * comments: Code manager *
13 * *
14 * Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ *
15 * $Log: not supported by cvs2svn $
16 * Revision 1.230 2008/06/02 17:20:28 vsc
17 * fix abolish bug
18 *
19 * Revision 1.229 2008/05/28 17:18:35 vsc
20 * thread fixes
21 *
22 * Revision 1.228 2008/04/28 23:02:32 vsc
23 * fix bug in current_predicate/2
24 * fix bug in c_interface.
25 *
26 * Revision 1.227 2008/04/11 16:30:27 ricroc
27 * *** empty log message ***
28 *
29 * Revision 1.226 2008/04/01 22:28:41 vsc
30 * put YAPOR back to life.
31 *
32 * Revision 1.225 2008/04/01 08:42:45 vsc
33 * fix restore and small VISTA thingies
34 *
35 * Revision 1.224 2008/03/31 22:56:21 vsc
36 * more fixes
37 *
38 * Revision 1.223 2008/03/25 16:45:53 vsc
39 * make or-parallelism compile again
40 *
41 * Revision 1.222 2008/03/24 23:48:47 vsc
42 * fix maximum number of threads open error
43 *
44 * Revision 1.221 2008/03/22 23:35:00 vsc
45 * fix bug in all_calls
46 *
47 * Revision 1.220 2008/03/17 18:31:16 vsc
48 * fix breakage in module system
49 * disable stack writing in error for now
50 *
51 * Revision 1.219 2008/02/22 15:08:33 vsc
52 * Big update to support more SICStus/SWI like message handling
53 * fix YAPSHAREDIR
54 * fix yap.tex (Bernd)
55 *
56 * Revision 1.218 2008/01/23 17:57:44 vsc
57 * valgrind it!
58 * enable atom garbage collection.
59 *
60 * Revision 1.217 2007/12/26 19:50:40 vsc
61 * new version of clp(fd)
62 * fix deadlock with empty args facts in clause/2.
63 *
64 * Revision 1.216 2007/12/23 22:48:44 vsc
65 * recover stack space
66 *
67 * Revision 1.215 2007/12/18 17:46:58 vsc
68 * purge_clauses does not need to do anything if there are no clauses
69 * fix gprof bugs.
70 *
71 * Revision 1.214 2007/11/28 23:52:14 vsc
72 * junction tree algorithm
73 *
74 * Revision 1.213 2007/11/26 23:43:07 vsc
75 * fixes to support threads and assert correctly, even if inefficiently.
76 *
77 * Revision 1.212 2007/11/16 14:58:40 vsc
78 * implement sophisticated operations with matrices.
79 *
80 * Revision 1.211 2007/11/08 09:53:01 vsc
81 * YAP would always say the system has tabling!
82 *
83 * Revision 1.210 2007/11/07 09:25:27 vsc
84 * speedup meta-calls
85 *
86 * Revision 1.209 2007/11/06 17:02:11 vsc
87 * compile ground terms away.
88 *
89 * Revision 1.208 2007/11/01 10:01:35 vsc
90 * fix uninitalised lock and reconsult test.
91 *
92 * Revision 1.207 2007/10/29 22:48:54 vsc
93 * small fixes
94 *
95 * Revision 1.206 2007/04/10 22:13:20 vsc
96 * fix max modules limitation
97 *
98 * Revision 1.205 2007/03/26 15:18:43 vsc
99 * debugging and clause/3 over tabled predicates would kill YAP.
100 *
101 * Revision 1.204 2007/01/25 22:11:55 vsc
102 * all/3 should fail on no solutions.
103 * get rid of annoying gcc complaints.
104 *
105 * Revision 1.203 2007/01/24 10:01:38 vsc
106 * fix matrix mess
107 *
108 * Revision 1.202 2006/12/27 01:32:37 vsc
109 * diverse fixes
110 *
111 * Revision 1.201 2006/12/13 16:10:14 vsc
112 * several debugger and CLP(BN) improvements.
113 *
114 * Revision 1.200 2006/11/27 17:42:02 vsc
115 * support for UNICODE, and other bug fixes.
116 *
117 * Revision 1.199 2006/11/15 00:13:36 vsc
118 * fixes for indexing code.
119 *
120 * Revision 1.198 2006/11/14 11:42:25 vsc
121 * fix bug in growstack
122 *
123 * Revision 1.197 2006/11/06 18:35:03 vsc
124 * 1estranha
125 *
126 * Revision 1.196 2006/10/16 17:12:48 vsc
127 * fixes for threaded version.
128 *
129 * Revision 1.195 2006/10/11 17:24:36 vsc
130 * make sure we only follow pointers *before* we removed the respective code block,
131 * ie don't kill the child before checking pointers from parent!
132 *
133 * Revision 1.194 2006/10/11 15:08:03 vsc
134 * fix bb entries
135 * comment development code for timestamp overflow.
136 *
137 * Revision 1.193 2006/10/11 14:53:57 vsc
138 * fix memory leak
139 * fix overflow handling
140 * VS: ----------------------------------------------------------------------
141 *
142 * Revision 1.192 2006/10/10 14:08:16 vsc
143 * small fixes on threaded implementation.
144 *
145 * Revision 1.191 2006/09/20 20:03:51 vsc
146 * improve indexing on floats
147 * fix sending large lists to DB
148 *
149 * Revision 1.190 2006/08/07 18:51:44 vsc
150 * fix garbage collector not to try to garbage collect when we ask for large
151 * chunks of stack in a single go.
152 *
153 * Revision 1.189 2006/05/24 02:35:39 vsc
154 * make chr work and other minor fixes.
155 *
156 * Revision 1.188 2006/05/18 16:33:04 vsc
157 * fix info reported by memory manager under DL_MALLOC and SYSTEM_MALLOC
158 *
159 * Revision 1.187 2006/04/29 01:15:18 vsc
160 * fix expand_consult patch
161 *
162 * Revision 1.186 2006/04/28 17:53:44 vsc
163 * fix the expand_consult patch
164 *
165 * Revision 1.185 2006/04/28 13:23:22 vsc
166 * fix number of overflow bugs affecting threaded version
167 * make current_op faster.
168 *
169 * Revision 1.184 2006/04/27 14:11:57 rslopes
170 * *** empty log message ***
171 *
172 * Revision 1.183 2006/03/29 16:00:10 vsc
173 * make tabling compile
174 *
175 * Revision 1.182 2006/03/24 16:26:26 vsc
176 * code review
177 *
178 * Revision 1.181 2006/03/22 20:07:28 vsc
179 * take better care of zombies
180 *
181 * Revision 1.180 2006/03/22 16:14:20 vsc
182 * don't be too eager at throwing indexing code for static predicates away.
183 *
184 * Revision 1.179 2006/03/21 17:11:39 vsc
185 * prevent breakage
186 *
187 * Revision 1.178 2006/03/20 19:51:43 vsc
188 * fix indexing and tabling bugs
189 *
190 * Revision 1.177 2006/03/06 14:04:56 vsc
191 * fixes to garbage collector
192 * fixes to debugger
193 *
194 * Revision 1.176 2006/02/01 13:28:56 vsc
195 * bignum support fixes
196 *
197 * Revision 1.175 2006/01/08 03:12:00 vsc
198 * fix small bug in attvar handling.
199 *
200 * Revision 1.174 2005/12/23 00:20:13 vsc
201 * updates to gprof
202 * support for __POWER__
203 * Try to saveregs before _longjmp.
204 *
205 * Revision 1.173 2005/12/17 03:25:39 vsc
206 * major changes to support online event-based profiling
207 * improve error discovery and restart on scanner.
208 *
209 * Revision 1.172 2005/11/23 03:01:33 vsc
210 * fix several bugs in save/restore.b
211 *
212 * Revision 1.171 2005/10/29 01:28:37 vsc
213 * make undefined more ISO compatible.
214 *
215 * Revision 1.170 2005/10/18 17:04:43 vsc
216 * 5.1:
217 * - improvements to GC
218 * 2 generations
219 * generic speedups
220 * - new scheme for attvars
221 * - hProlog like interface also supported
222 * - SWI compatibility layer
223 * - extra predicates
224 * - global variables
225 * - moved to Prolog module
226 * - CLP(R) by Leslie De Koninck, Tom Schrijvers, Cristian Holzbaur, Bart
227 * Demoen and Jan Wielemacker
228 * - load_files/2
229 *
230 * from 5.0.1
231 *
232 * - WIN32 missing include files (untested)
233 * - -L trouble (my thanks to Takeyuchi Shiramoto-san)!
234 * - debugging of backtrable user-C preds would core dump.
235 * - redeclaring a C-predicate as Prolog core dumps.
236 * - badly protected YapInterface.h.
237 * - break/0 was failing at exit.
238 * - YAP_cut_fail and YAP_cut_succeed were different from manual.
239 * - tracing through data-bases could core dump.
240 * - cut could break on very large computations.
241 * - first pass at BigNum issues (reported by Roberto).
242 * - debugger could get go awol after fail port.
243 * - weird message on wrong debugger option.
244 *
245 * Revision 1.169 2005/10/15 02:05:57 vsc
246 * fix for trying to add clauses to a C pred.
247 *
248 * Revision 1.168 2005/08/05 14:55:02 vsc
249 * first steps to allow mavars with tabling
250 * fix trailing for tabling with multiple get_cons
251 *
252 * Revision 1.167 2005/08/02 03:09:49 vsc
253 * fix debugger to do well nonsource predicates.
254 *
255 * Revision 1.166 2005/08/01 15:40:37 ricroc
256 * TABLING NEW: better support for incomplete tabling
257 *
258 * Revision 1.165 2005/07/06 19:33:52 ricroc
259 * TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
260 *
261 * Revision 1.164 2005/07/06 15:10:03 vsc
262 * improvements to compiler: merged instructions and fixes for ->
263 *
264 * Revision 1.163 2005/06/08 00:35:27 vsc
265 * fix silly calls such as 0.15 ( bug reported by Jude Shavlik)
266 *
267 * Revision 1.162 2005/06/04 07:27:33 ricroc
268 * long int support for tabling
269 *
270 * Revision 1.161 2005/06/03 08:26:32 ricroc
271 * float support for tabling
272 *
273 * Revision 1.160 2005/06/01 14:02:47 vsc
274 * get_rid of try_me?, retry_me? and trust_me? instructions: they are not
275 * significantly used nowadays.
276 *
277 * Revision 1.159 2005/05/31 19:42:27 vsc
278 * insert some more slack for indices in LU
279 * Use doubly linked list for LU indices so that updating is less cumbersome.
280 *
281 * Revision 1.158 2005/05/31 00:30:23 ricroc
282 * remove abort_yapor function
283 *
284 * Revision 1.157 2005/05/12 03:36:32 vsc
285 * debugger was making predicates meta instead of testing
286 * fix handling of dbrefs in facts and in subarguments.
287 *
288 * Revision 1.156 2005/04/20 04:02:15 vsc
289 * fix a few variable warnings
290 * fix erase clause to pass a pointer to clause, not code
291 * get rid of Yap4.4 code in Yap_EraseStaticClause
292 *
293 * Revision 1.155 2005/04/10 04:01:10 vsc
294 * bug fixes, I hope!
295 *
296 * Revision 1.154 2005/03/04 20:30:11 ricroc
297 * bug fixes for YapTab support
298 *
299 * Revision 1.153 2005/02/25 03:39:44 vsc
300 * fix fixes to undefp
301 * fix bug where clause mistook cp for ap
302 *
303 * Revision 1.152 2005/02/08 18:04:57 vsc
304 * library_directory may not be deterministic (usually it isn't).
305 *
306 * Revision 1.151 2005/02/08 04:05:23 vsc
307 * fix mess with add clause
308 * improves on sigsegv handling
309 *
310 * Revision 1.150 2005/01/28 23:14:34 vsc
311 * move to Yap-4.5.7
312 * Fix clause size
313 *
314 * Revision 1.149 2005/01/05 05:35:01 vsc
315 * get rid of debugging stub.
316 *
317 * Revision 1.148 2005/01/04 02:50:21 vsc
318 * - allow MegaClauses with blobs
319 * - change Diffs to be thread specific
320 * - include Christian's updates
321 *
322 * Revision 1.147 2004/12/28 22:20:35 vsc
323 * some extra bug fixes for trail overflows: some cannot be recovered that easily,
324 * some can.
325 *
326 * Revision 1.146 2004/12/20 21:44:57 vsc
327 * more fixes to CLPBN
328 * fix some Yap overflows.
329 *
330 * Revision 1.145 2004/12/16 05:57:23 vsc
331 * fix overflows
332 *
333 * Revision 1.144 2004/12/08 00:10:48 vsc
334 * more grow fixes
335 *
336 * Revision 1.143 2004/12/05 05:01:23 vsc
337 * try to reduce overheads when running with goal expansion enabled.
338 * CLPBN fixes
339 * Handle overflows when allocating big clauses properly.
340 *
341 * Revision 1.142 2004/11/18 22:32:31 vsc
342 * fix situation where we might assume nonextsing double initialisation of C predicates (use
343 * Hidden Pred Flag).
344 * $host_type was double initialised.
345 *
346 * Revision 1.141 2004/11/04 18:22:31 vsc
347 * don't ever use memory that has been freed (that was done by LU).
348 * generic fixes for WIN32 libraries
349 *
350 * Revision 1.140 2004/10/31 02:18:03 vsc
351 * fix bug in handling Yap heap overflow while adding new clause.
352 *
353 * Revision 1.139 2004/10/28 20:12:21 vsc
354 * Use Doug Lea's malloc as an alternative to YAP's standard malloc
355 * don't use TR directly in scanner/parser, this avoids trouble with ^C while
356 * consulting large files.
357 * pass gcc -mno-cygwin to library compilation in cygwin environment (cygwin should
358 * compile out of the box now).
359 *
360 * Revision 1.138 2004/10/26 20:15:51 vsc
361 * More bug fixes for overflow handling
362 *
363 * Revision 1.137 2004/10/22 16:53:19 vsc
364 * bug fixes
365 *
366 * Revision 1.136 2004/10/06 16:55:46 vsc
367 * change configure to support big mem configs
368 * get rid of extra globals
369 * fix trouble with multifile preds
370 *
371 * Revision 1.135 2004/09/30 21:37:40 vsc
372 * fixes for thread support
373 *
374 * Revision 1.134 2004/09/30 19:51:53 vsc
375 * fix overflow from within clause/2
376 *
377 * Revision 1.133 2004/09/27 20:45:02 vsc
378 * Mega clauses
379 * Fixes to sizeof(expand_clauses) which was being overestimated
380 * Fixes to profiling+indexing
381 * Fixes to reallocation of memory after restoring
382 * Make sure all clauses, even for C, end in _Ystop
383 * Don't reuse space for Streams
384 * Fix Stream_F on StreaNo+1
385 *
386 * Revision 1.132 2004/09/17 19:34:51 vsc
387 * simplify frozen/2
388 *
389 * Revision 1.131 2004/09/08 17:56:45 vsc
390 * source: a(X) :- true is a fact!
391 * fix use of value after possible overflow in IPred
392 *
393 * Revision 1.130 2004/09/07 16:48:04 vsc
394 * fix bug in unwinding trail at amiops.h
395 *
396 * Revision 1.129 2004/09/07 16:25:22 vsc
397 * memory management bug fixes
398 *
399 * Revision 1.128 2004/09/03 03:11:07 vsc
400 * memory management fixes
401 *
402 * Revision 1.127 2004/08/16 21:02:04 vsc
403 * more fixes for !
404 *
405 * Revision 1.126 2004/07/22 21:32:20 vsc
406 * debugger fixes
407 * initial support for JPL
408 * bad calls to garbage collector and gc
409 * debugger fixes
410 *
411 * Revision 1.125 2004/06/29 19:04:41 vsc
412 * fix multithreaded version
413 * include new version of Ricardo's profiler
414 * new predicat atomic_concat
415 * allow multithreaded-debugging
416 * small fixes
417 *
418 * Revision 1.124 2004/06/05 03:36:59 vsc
419 * coroutining is now a part of attvars.
420 * some more fixes.
421 *
422 * Revision 1.123 2004/05/17 21:42:09 vsc
423 * misc fixes
424 *
425 * Revision 1.122 2004/05/13 21:36:45 vsc
426 * get rid of pesky debugging prints
427 *
428 * Revision 1.121 2004/05/13 20:54:57 vsc
429 * debugger fixes
430 * make sure we always go back to current module, even during initizlization.
431 *
432 * Revision 1.120 2004/04/27 16:21:16 vsc
433 * stupid bug
434 *
435 * Revision 1.119 2004/04/27 15:03:43 vsc
436 * more fixes for expand_clauses
437 *
438 * Revision 1.118 2004/04/14 19:10:23 vsc
439 * expand_clauses: keep a list of clauses to expand
440 * fix new trail scheme for multi-assignment variables
441 *
442 * Revision 1.117 2004/04/07 22:04:03 vsc
443 * fix memory leaks
444 *
445 * Revision 1.116 2004/03/31 01:03:09 vsc
446 * support expand group of clauses
447 *
448 * Revision 1.115 2004/03/19 11:35:42 vsc
449 * trim_trail for default machine
450 * be more aggressive about try-retry-trust chains.
451 * - handle cases where block starts with a wait
452 * - don't use _killed instructions, just let the thing rot by itself.
453 *
454 * *
455 *************************************************************************/
456 #ifdef SCCS
457 static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
458 #endif
459
460 #include "Yap.h"
461 #include "clause.h"
462 #include "yapio.h"
463 #include "eval.h"
464 #include "tracer.h"
465 #ifdef YAPOR
466 #include "or.macros.h"
467 #endif /* YAPOR */
468 #ifdef TABLING
469 #include "tab.macros.h"
470 #endif /* TABLING */
471 #if HAVE_STRING_H
472 #include <string.h>
473 #endif
474
475
476 STATIC_PROTO(void retract_all, (PredEntry *, int));
477 STATIC_PROTO(void add_first_static, (PredEntry *, yamop *, int));
478 STATIC_PROTO(void add_first_dynamic, (PredEntry *, yamop *, int));
479 STATIC_PROTO(void asserta_stat_clause, (PredEntry *, yamop *, int));
480 STATIC_PROTO(void asserta_dynam_clause, (PredEntry *, yamop *));
481 STATIC_PROTO(void assertz_stat_clause, (PredEntry *, yamop *, int));
482 STATIC_PROTO(void assertz_dynam_clause, (PredEntry *, yamop *));
483 STATIC_PROTO(void expand_consult, (void));
484 STATIC_PROTO(int not_was_reconsulted, (PredEntry *, Term, int));
485 STATIC_PROTO(int RemoveIndexation, (PredEntry *));
486 #if EMACS
487 STATIC_PROTO(int last_clause_number, (PredEntry *));
488 #endif
489 STATIC_PROTO(int static_in_use, (PredEntry *, int));
490 #if !defined(YAPOR) && !defined(THREADS)
491 STATIC_PROTO(Int search_for_static_predicate_in_use, (PredEntry *, int));
492 STATIC_PROTO(void mark_pred, (int, PredEntry *));
493 STATIC_PROTO(void do_toggle_static_predicates_in_use, (int));
494 #endif
495 STATIC_PROTO(Int p_number_of_clauses, (void));
496 STATIC_PROTO(Int p_compile, (void));
497 STATIC_PROTO(Int p_compile_dynamic, (void));
498 STATIC_PROTO(Int p_purge_clauses, (void));
499 STATIC_PROTO(Int p_setspy, (void));
500 STATIC_PROTO(Int p_rmspy, (void));
501 STATIC_PROTO(Int p_startconsult, (void));
502 STATIC_PROTO(Int p_showconslultlev, (void));
503 STATIC_PROTO(Int p_endconsult, (void));
504 STATIC_PROTO(Int p_undefined, (void));
505 STATIC_PROTO(Int p_in_use, (void));
506 STATIC_PROTO(Int p_new_multifile, (void));
507 STATIC_PROTO(Int p_is_multifile, (void));
508 STATIC_PROTO(Int p_optimizer_on, (void));
509 STATIC_PROTO(Int p_optimizer_off, (void));
510 STATIC_PROTO(Int p_is_dynamic, (void));
511 STATIC_PROTO(Int p_kill_dynamic, (void));
512 STATIC_PROTO(Int p_compile_mode, (void));
513 STATIC_PROTO(Int p_is_profiled, (void));
514 STATIC_PROTO(Int p_profile_info, (void));
515 STATIC_PROTO(Int p_profile_reset, (void));
516 STATIC_PROTO(Int p_is_call_counted, (void));
517 STATIC_PROTO(Int p_call_count_info, (void));
518 STATIC_PROTO(Int p_call_count_set, (void));
519 STATIC_PROTO(Int p_call_count_reset, (void));
520 STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void));
521 STATIC_PROTO(Atom YapConsultingFile, (void));
522 STATIC_PROTO(Int PredForCode,(yamop *, Atom *, UInt *, Term *));
523 STATIC_PROTO(void kill_first_log_iblock,(LogUpdIndex *, LogUpdIndex *, PredEntry *));
524 STATIC_PROTO(LogUpdIndex *find_owner_log_index,(LogUpdIndex *, yamop *));
525 STATIC_PROTO(StaticIndex *find_owner_static_index,(StaticIndex *, yamop *));
526
527 #define PredArity(p) (p->ArityOfPE)
528 #define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G)
529 #define NEXTOP(V,TYPE) ((yamop *)(&((V)->u.TYPE.next)))
530
531 #define IN_BLOCK(P,B,SZ) ((CODEADDR)(P) >= (CODEADDR)(B) && \
532 (CODEADDR)(P) < (CODEADDR)(B)+(SZ))
533
534 static PredEntry *
PredForChoicePt(yamop * p_code)535 PredForChoicePt(yamop *p_code) {
536 while (TRUE) {
537 op_numbers opnum;
538 if (!p_code)
539 return NULL;
540 opnum = Yap_op_from_opcode(p_code->opc);
541 switch(opnum) {
542 case _Nstop:
543 return NULL;
544 case _jump:
545 p_code = p_code->u.l.l;
546 break;
547 case _retry_me:
548 case _trust_me:
549 return p_code->u.Otapl.p;
550 case _try_logical:
551 case _retry_logical:
552 case _trust_logical:
553 case _count_retry_logical:
554 case _count_trust_logical:
555 case _profiled_retry_logical:
556 case _profiled_trust_logical:
557 return p_code->u.OtaLl.d->ClPred;
558 #ifdef TABLING
559 case _trie_trust_var:
560 case _trie_retry_var:
561 case _trie_trust_var_in_pair:
562 case _trie_retry_var_in_pair:
563 case _trie_trust_val:
564 case _trie_retry_val:
565 case _trie_trust_val_in_pair:
566 case _trie_retry_val_in_pair:
567 case _trie_trust_atom:
568 case _trie_retry_atom:
569 case _trie_trust_atom_in_pair:
570 case _trie_retry_atom_in_pair:
571 case _trie_trust_null:
572 case _trie_retry_null:
573 case _trie_trust_null_in_pair:
574 case _trie_retry_null_in_pair:
575 case _trie_trust_pair:
576 case _trie_retry_pair:
577 case _trie_trust_appl:
578 case _trie_retry_appl:
579 case _trie_trust_appl_in_pair:
580 case _trie_retry_appl_in_pair:
581 case _trie_trust_extension:
582 case _trie_retry_extension:
583 case _trie_trust_double:
584 case _trie_retry_double:
585 case _trie_trust_longint:
586 case _trie_retry_longint:
587 case _trie_trust_gterm:
588 case _trie_retry_gterm:
589 return NULL;
590 case _table_load_answer:
591 case _table_try_answer:
592 case _table_answer_resolution:
593 case _table_completion:
594 return NULL; /* ricroc: is this OK? */
595 /* compile error --> return ENV_ToP(gc_B->cp_cp); */
596 #endif /* TABLING */
597 case _or_else:
598 if (p_code == p_code->u.Osblp.l) {
599 /* repeat */
600 Atom at = AtomRepeatSpace;
601 return RepPredProp(PredPropByAtom(at, PROLOG_MODULE));
602 } else {
603 return p_code->u.Osblp.p0;
604 }
605 break;
606 case _or_last:
607 #ifdef YAPOR
608 return p_code->u.Osblp.p0;
609 #else
610 return p_code->u.p.p;
611 #endif /* YAPOR */
612 break;
613 case _count_retry_me:
614 case _retry_profiled:
615 case _retry2:
616 case _retry3:
617 case _retry4:
618 p_code = NEXTOP(p_code,l);
619 break;
620 default:
621 return p_code->u.Otapl.p;
622 }
623 }
624 return NULL;
625 }
626
627 PredEntry *
Yap_PredForChoicePt(choiceptr cp)628 Yap_PredForChoicePt(choiceptr cp) {
629 if (cp == NULL)
630 return NULL;
631 return PredForChoicePt(cp->cp_ap);
632 }
633
634 static void
InitConsultStack(void)635 InitConsultStack(void)
636 {
637 ConsultLow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
638 if (ConsultLow == NULL) {
639 Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
640 return;
641 }
642 ConsultCapacity = InitialConsultCapacity;
643 ConsultBase = ConsultSp =
644 ConsultLow + ConsultCapacity;
645 }
646
647 void
Yap_ResetConsultStack(void)648 Yap_ResetConsultStack(void)
649 {
650 Yap_FreeCodeSpace((char *)ConsultLow);
651 ConsultBase =
652 ConsultSp =
653 ConsultLow =
654 NULL;
655 ConsultCapacity = InitialConsultCapacity;
656 }
657
658
659 /******************************************************************
660
661 EXECUTING PROLOG CLAUSES
662
663 ******************************************************************/
664
665
666 static int
static_in_use(PredEntry * p,int check_everything)667 static_in_use(PredEntry *p, int check_everything)
668 {
669 #if defined(YAPOR) || defined(THREADS)
670 return TRUE;
671 #else
672 CELL pflags = p->PredFlags;
673 if (pflags & (DynamicPredFlag|LogUpdatePredFlag)) {
674 return FALSE;
675 }
676 if (STATIC_PREDICATES_MARKED) {
677 return (p->PredFlags & InUsePredFlag);
678 } else {
679 /* This code does not work for YAPOR or THREADS!!!!!!!! */
680 return(search_for_static_predicate_in_use(p, check_everything));
681 }
682 #endif
683 }
684
685 /******************************************************************
686
687 ADDING AND REMOVE INFO TO A PROCEDURE
688
689 ******************************************************************/
690
691
692 /*
693 * we have three kinds of predicates: dynamic DynamicPredFlag
694 * static CompiledPredFlag fast FastPredFlag all the
695 * database predicates are supported for dynamic predicates only abolish and
696 * assertz are supported for static predicates no database predicates are
697 * supportted for fast predicates
698 */
699
700 #define is_dynamic(pe) (pe->PredFlags & DynamicPredFlag)
701 #define is_static(pe) (pe->PredFlags & CompiledPredFlag)
702 #define is_logupd(pe) (pe->PredFlags & LogUpdatePredFlag)
703 #ifdef TABLING
704 #define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
705 #endif /* TABLING */
706
707
708 static PredEntry *
get_pred(Term t,Term tmod,char * pname)709 get_pred(Term t, Term tmod, char *pname)
710 {
711 Term t0 = t;
712
713 restart:
714 if (IsVarTerm(t)) {
715 Yap_Error(INSTANTIATION_ERROR, t0, pname);
716 return NULL;
717 } else if (IsAtomTerm(t)) {
718 return RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
719 } else if (IsIntegerTerm(t) && tmod == IDB_MODULE) {
720 return Yap_FindLUIntKey(IntegerOfTerm(t));
721 } else if (IsApplTerm(t)) {
722 Functor fun = FunctorOfTerm(t);
723 if (IsExtensionFunctor(fun)) {
724 Yap_Error(TYPE_ERROR_CALLABLE, t0, pname);
725 return NULL;
726 }
727 if (fun == FunctorModule) {
728 Term tmod = ArgOfTerm(1, t);
729 if (IsVarTerm(tmod) ) {
730 Yap_Error(INSTANTIATION_ERROR, t0, pname);
731 return NULL;
732 }
733 if (!IsAtomTerm(tmod) ) {
734 Yap_Error(TYPE_ERROR_ATOM, t0, pname);
735 return NULL;
736 }
737 t = ArgOfTerm(2, t);
738 goto restart;
739 }
740 return RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
741 } else
742 return NULL;
743 }
744
745 /******************************************************************
746
747 Mega Clauses
748
749 ******************************************************************/
750
751
752 #define OrArgAdjust(P)
753 #define TabEntryAdjust(P)
754 #define DoubleInCodeAdjust(D)
755 #define IntegerInCodeAdjust(D)
756 #define IntegerAdjust(D) (D)
757 #define PtoPredAdjust(X) (X)
758 #define PtoOpAdjust(X) (X)
759 #define PtoLUClauseAdjust(P) (P)
760 #define PtoLUIndexAdjust(P) (P)
761 #define XAdjust(X) (X)
762 #define YAdjust(X) (X)
763 #define AtomTermAdjust(X) (X)
764 #define CellPtoHeapAdjust(X) (X)
765 #define FuncAdjust(X) (X)
766 #define CodeAddrAdjust(X) (X)
767 #define CodeComposedTermAdjust(X) (X)
768 #define ConstantAdjust(X) (X)
769 #define ArityAdjust(X) (X)
770 #define OpcodeAdjust(X) (X)
771 #define ModuleAdjust(X) (X)
772 #define ExternalFunctionAdjust(X) (X)
773 #define AdjustSwitchTable(X,Y,Z)
774 #define DBGroundTermAdjust(X) (X)
775 #define rehash(A,B,C)
776
BlobTermInCodeAdjust(Term t)777 static Term BlobTermInCodeAdjust(Term t)
778 {
779 #if TAGS_FAST_OPS
780 return t-ClDiff;
781 #else
782 return t+ClDiff;
783 #endif
784 }
785
786 static Term
ConstantTermAdjust(Term t)787 ConstantTermAdjust (Term t)
788 {
789 if (IsAtomTerm(t))
790 return AtomTermAdjust(t);
791 return t;
792 }
793
794
795 #include "rclause.h"
796
797 #ifdef DEBUG
798 static UInt total_megaclause, total_released, nof_megaclauses;
799 #endif
800
801 void
Yap_BuildMegaClause(PredEntry * ap)802 Yap_BuildMegaClause(PredEntry *ap)
803 {
804 StaticClause *cl;
805 UInt sz;
806 MegaClause *mcl;
807 yamop *ptr;
808 UInt required;
809 UInt has_blobs = 0;
810
811 if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|MegaClausePredFlag
812 #ifdef TABLING
813 |TabledPredFlag
814 #endif /* TABLING */
815 |UDIPredFlag) ||
816 ap->cs.p_code.FirstClause == NULL ||
817 ap->cs.p_code.NOfClauses < 16) {
818 return;
819 }
820 cl =
821 ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
822 sz = cl->ClSize;
823 while (TRUE) {
824 if (!(cl->ClFlags & FactMask)) return; /* no mega clause, sorry */
825 if (cl->ClSize != sz) return; /* no mega clause, sorry */
826 if (cl->ClCode == ap->cs.p_code.LastClause)
827 break;
828 has_blobs |= (cl->ClFlags & HasBlobsMask);
829 cl = cl->ClNext;
830 }
831 /* ok, we got the chance for a mega clause */
832 if (has_blobs) {
833 sz -= sizeof(StaticClause);
834 } else {
835 sz -= (UInt)NEXTOP((yamop *)NULL,p) + sizeof(StaticClause);
836 }
837 required = sz*ap->cs.p_code.NOfClauses+sizeof(MegaClause)+(UInt)NEXTOP((yamop *)NULL,l);
838 #ifdef DEBUG
839 total_megaclause += required;
840 total_released += ap->cs.p_code.NOfClauses*(sz+sizeof(StaticClause));
841 nof_megaclauses++;
842 #endif
843 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
844 if (!Yap_growheap(FALSE, required, NULL)) {
845 /* just fail, the system will keep on going */
846 return;
847 }
848 }
849 Yap_ClauseSpace += required;
850 /* cool, it's our turn to do the conversion */
851 mcl->ClFlags = MegaMask | has_blobs;
852 mcl->ClSize = sz*ap->cs.p_code.NOfClauses;
853 mcl->ClPred = ap;
854 mcl->ClItemSize = sz;
855 mcl->ClNext = NULL;
856 cl =
857 ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
858 ptr = mcl->ClCode;
859 while (TRUE) {
860 memcpy((void *)ptr, (void *)cl->ClCode, sz);
861 if (has_blobs) {
862 ClDiff = (char *)(ptr)-(char *)cl->ClCode;
863 restore_opcodes(ptr, NULL);
864 }
865 ptr = (yamop *)((char *)ptr + sz);
866 if (cl->ClCode == ap->cs.p_code.LastClause)
867 break;
868 cl = cl->ClNext;
869 }
870 ptr->opc = Yap_opcode(_Ystop);
871 cl =
872 ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
873 /* recover the space spent on the original clauses */
874 while (TRUE) {
875 StaticClause *ncl, *curcl = cl;
876
877 ncl = cl->ClNext;
878 Yap_InformOfRemoval((CODEADDR)cl);
879 Yap_ClauseSpace -= cl->ClSize;
880 Yap_FreeCodeSpace((ADDR)cl);
881 if (curcl->ClCode == ap->cs.p_code.LastClause)
882 break;
883 cl = ncl;
884 }
885 ap->cs.p_code.FirstClause =
886 ap->cs.p_code.LastClause =
887 mcl->ClCode;
888 ap->PredFlags |= MegaClausePredFlag;
889 }
890
891
892 static void
split_megaclause(PredEntry * ap)893 split_megaclause(PredEntry *ap)
894 {
895 StaticClause *start = NULL, *prev = NULL;
896 MegaClause *mcl;
897 yamop *ptr;
898 UInt ncls = ap->cs.p_code.NOfClauses, i;
899
900 RemoveIndexation(ap);
901 mcl =
902 ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
903 for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
904 StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(sizeof(StaticClause)+mcl->ClItemSize+(UInt)NEXTOP((yamop *)NULL,p));
905 if (new == NULL) {
906 if (!Yap_growheap(FALSE, (sizeof(StaticClause)+mcl->ClItemSize)*(ncls-i), NULL)) {
907 while (start) {
908 StaticClause *cl = start;
909 start = cl->ClNext;
910 Yap_InformOfRemoval((CODEADDR)cl);
911 Yap_ClauseSpace -= cl->ClSize;
912 Yap_FreeCodeSpace((char *)cl);
913 }
914 if (ap->ArityOfPE) {
915 Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s/%d\n",RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,ap->ArityOfPE);
916 } else {
917 Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s\n", RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
918 }
919 return;
920 }
921 break;
922 }
923 Yap_ClauseSpace += sizeof(StaticClause)+mcl->ClItemSize+(UInt)NEXTOP((yamop *)NULL,p);
924 new->ClFlags = StaticMask|FactMask;
925 new->ClSize = mcl->ClItemSize;
926 new->usc.ClPred = ap;
927 new->ClNext = NULL;
928 memcpy((void *)new->ClCode, (void *)ptr, mcl->ClItemSize);
929 if (prev) {
930 prev->ClNext = new;
931 } else {
932 start = new;
933 }
934 ptr = (yamop *)((char *)ptr + mcl->ClItemSize);
935 prev = new;
936 }
937 ap->PredFlags &= ~MegaClausePredFlag;
938 ap->cs.p_code.FirstClause = start->ClCode;
939 ap->cs.p_code.LastClause = prev->ClCode;
940 }
941
942
943
944 /******************************************************************
945
946 Indexation Info
947
948 ******************************************************************/
949 #define ByteAdr(X) ((Int) &(X))
950
951 /* Index a prolog pred, given its predicate entry */
952 /* ap is already locked. */
953 static void
IPred(PredEntry * ap,UInt NSlots,yamop * next_pc)954 IPred(PredEntry *ap, UInt NSlots, yamop *next_pc)
955 {
956 yamop *BaseAddr;
957
958 #ifdef DEBUG
959 if (Yap_Option['i' - 'a' + 1]) {
960 Term tmod = ap->ModuleOfPred;
961 if (!tmod)
962 tmod = TermProlog;
963 Yap_DebugPutc(Yap_c_error_stream,'\t');
964 Yap_DebugPlWrite(tmod);
965 Yap_DebugPutc(Yap_c_error_stream,':');
966 if (ap->ModuleOfPred == IDB_MODULE) {
967 Term t = Deref(ARG1);
968 if (IsAtomTerm(t)) {
969 Yap_DebugPlWrite(t);
970 } else if (IsIntegerTerm(t)) {
971 Yap_DebugPlWrite(t);
972 } else {
973 Functor f = FunctorOfTerm(t);
974 Atom At = NameOfFunctor(f);
975 Yap_DebugPlWrite(MkAtomTerm(At));
976 Yap_DebugPutc(Yap_c_error_stream,'/');
977 Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
978 }
979 } else {
980 if (ap->ArityOfPE == 0) {
981 Atom At = (Atom)ap->FunctorOfPred;
982 Yap_DebugPlWrite(MkAtomTerm(At));
983 } else {
984 Functor f = ap->FunctorOfPred;
985 Atom At = NameOfFunctor(f);
986 Yap_DebugPlWrite(MkAtomTerm(At));
987 Yap_DebugPutc(Yap_c_error_stream,'/');
988 Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
989 }
990 }
991 Yap_DebugPutc(Yap_c_error_stream,'\n');
992 }
993 #endif
994 /* Do not try to index a dynamic predicate or one whithout args */
995 if (is_dynamic(ap)) {
996 Yap_Error(SYSTEM_ERROR,TermNil,"trying to index a dynamic predicate");
997 return;
998 }
999 if ((BaseAddr = Yap_PredIsIndexable(ap, NSlots, next_pc)) != NULL) {
1000 ap->cs.p_code.TrueCodeOfPred = BaseAddr;
1001 ap->PredFlags |= IndexedPredFlag;
1002 }
1003 if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
1004 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
1005 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1006 #if defined(YAPOR) || defined(THREADS)
1007 } else if (ap->PredFlags & LogUpdatePredFlag &&
1008 ap->ModuleOfPred != IDB_MODULE) {
1009 ap->OpcodeOfPred = LOCKPRED_OPCODE;
1010 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1011 #endif
1012 } else {
1013 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
1014 ap->OpcodeOfPred = ap->CodeOfPred->opc;
1015 }
1016 #ifdef DEBUG
1017 if (Yap_Option['i' - 'a' + 1])
1018 Yap_DebugPutc(Yap_c_error_stream,'\n');
1019 #endif
1020 }
1021
1022 void
Yap_IPred(PredEntry * p,UInt NSlots,yamop * next_pc)1023 Yap_IPred(PredEntry *p, UInt NSlots, yamop *next_pc)
1024 {
1025 IPred(p, NSlots, next_pc);
1026 }
1027
1028 #define GONEXT(TYPE) code_p = ((yamop *)(&(code_p->u.TYPE.next)))
1029
1030 static void
RemoveMainIndex(PredEntry * ap)1031 RemoveMainIndex(PredEntry *ap)
1032 {
1033 yamop *First = ap->cs.p_code.FirstClause;
1034 int spied = ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag);
1035
1036 ap->PredFlags &= ~IndexedPredFlag;
1037 if (First == NULL) {
1038 ap->cs.p_code.TrueCodeOfPred = FAILCODE;
1039 } else {
1040 ap->cs.p_code.TrueCodeOfPred = First;
1041 }
1042 if (First != NULL && spied) {
1043 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
1044 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1045 } else if (ap->cs.p_code.NOfClauses > 1
1046 #ifdef TABLING
1047 ||ap->PredFlags & TabledPredFlag
1048 #endif /* TABLING */
1049 ) {
1050 ap->OpcodeOfPred = INDEX_OPCODE;
1051 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1052 } else {
1053 ap->OpcodeOfPred = ap->cs.p_code.TrueCodeOfPred->opc;
1054 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
1055 }
1056 #if defined(YAPOR) || defined(THREADS)
1057 if (ap->PredFlags & LogUpdatePredFlag &&
1058 ap->ModuleOfPred != IDB_MODULE) {
1059 ap->OpcodeOfPred = LOCKPRED_OPCODE;
1060 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1061 }
1062 #endif
1063 }
1064
1065 static void
decrease_ref_counter(yamop * ptr,yamop * b,yamop * e,yamop * sc)1066 decrease_ref_counter(yamop *ptr, yamop *b, yamop *e, yamop *sc)
1067 {
1068 if (ptr != FAILCODE && ptr != sc && (ptr < b || ptr > e)) {
1069 LogUpdClause *cl = ClauseCodeToLogUpdClause(ptr);
1070 cl->ClRefCount--;
1071 if (cl->ClFlags & ErasedMask &&
1072 !(cl->ClRefCount) &&
1073 !(cl->ClFlags & InUseMask)) {
1074 /* last ref to the clause */
1075 Yap_ErLogUpdCl(cl);
1076 }
1077 }
1078 }
1079
1080 static yamop *
release_wcls(yamop * cop,OPCODE ecs)1081 release_wcls(yamop *cop, OPCODE ecs)
1082 {
1083 if (cop->opc == ecs) {
1084 cop->u.sssllp.s3--;
1085 if (!cop->u.sssllp.s3) {
1086 UInt sz = (UInt)NEXTOP((yamop *)NULL,sssllp)+cop->u.sssllp.s1*sizeof(yamop *);
1087 LOCK(ExpandClausesListLock);
1088 #ifdef DEBUG
1089 Yap_expand_clauses_sz -= sz;
1090 Yap_ExpandClauses--;
1091 #endif
1092 if (cop->u.sssllp.p->PredFlags & LogUpdatePredFlag) {
1093 Yap_LUIndexSpace_EXT -= sz;
1094 } else {
1095 Yap_IndexSpace_EXT -= sz;
1096 }
1097 if (ExpandClausesFirst == cop)
1098 ExpandClausesFirst = cop->u.sssllp.snext;
1099 if (ExpandClausesLast == cop) {
1100 ExpandClausesLast = cop->u.sssllp.sprev;
1101 }
1102 if (cop->u.sssllp.sprev) {
1103 cop->u.sssllp.sprev->u.sssllp.snext = cop->u.sssllp.snext;
1104 }
1105 if (cop->u.sssllp.snext) {
1106 cop->u.sssllp.snext->u.sssllp.sprev = cop->u.sssllp.sprev;
1107 }
1108 UNLOCK(ExpandClausesListLock);
1109 Yap_InformOfRemoval((CODEADDR)cop);
1110 Yap_FreeCodeSpace((char *)cop);
1111 }
1112 }
1113 return FAILCODE;
1114 }
1115
1116
1117 static void
cleanup_dangling_indices(yamop * ipc,yamop * beg,yamop * end,yamop * suspend_code)1118 cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code)
1119 {
1120 OPCODE ecs = Yap_opcode(_expand_clauses);
1121
1122 while (ipc) {
1123 op_numbers op = Yap_op_from_opcode(ipc->opc);
1124 /* fprintf(stderr,"op: %d %p->%p\n", op, ipc, end);*/
1125 switch(op) {
1126 case _Ystop:
1127 /* end of clause, for now */
1128 return;
1129 case _index_dbref:
1130 case _index_blob:
1131 case _index_long:
1132 ipc = NEXTOP(ipc,e);
1133 break;
1134 case _lock_lu:
1135 case _unlock_lu:
1136 /* locking should be done already */
1137 ipc = NEXTOP(ipc,e);
1138 case _retry_profiled:
1139 case _count_retry:
1140 ipc = NEXTOP(ipc,p);
1141 break;
1142 case _try_clause2:
1143 case _try_clause3:
1144 case _try_clause4:
1145 ipc = NEXTOP(ipc,l);
1146 break;
1147 case _retry2:
1148 case _retry3:
1149 case _retry4:
1150 decrease_ref_counter(ipc->u.l.l, beg, end, suspend_code);
1151 ipc = NEXTOP(ipc,l);
1152 break;
1153 case _retry:
1154 case _trust:
1155 decrease_ref_counter(ipc->u.Otapl.d, beg, end, suspend_code);
1156 ipc = NEXTOP(ipc,Otapl);
1157 break;
1158 case _try_clause:
1159 case _try_me:
1160 case _retry_me:
1161 case _profiled_trust_me:
1162 case _trust_me:
1163 case _count_trust_me:
1164 ipc = NEXTOP(ipc,Otapl);
1165 break;
1166 case _try_logical:
1167 case _retry_logical:
1168 case _count_retry_logical:
1169 case _profiled_retry_logical:
1170 {
1171 yamop *oipc = ipc;
1172 decrease_ref_counter(ipc->u.OtaLl.d->ClCode, beg, end, suspend_code);
1173 ipc = ipc->u.OtaLl.n;
1174 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,OtaLl);
1175 Yap_FreeCodeSpace((ADDR)oipc);
1176 #ifdef DEBUG
1177 Yap_DirtyCps--;
1178 Yap_FreedCps++;
1179 #endif
1180 }
1181 break;
1182 case _trust_logical:
1183 case _count_trust_logical:
1184 case _profiled_trust_logical:
1185 #ifdef DEBUG
1186 Yap_DirtyCps--;
1187 Yap_FreedCps++;
1188 #endif
1189 decrease_ref_counter(ipc->u.OtILl.d->ClCode, beg, end, suspend_code);
1190 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,OtILl);
1191 Yap_FreeCodeSpace((ADDR)ipc);
1192 return;
1193 case _enter_lu_pred:
1194 {
1195 yamop *oipc = ipc;
1196 if (ipc->u.Ills.I->ClFlags & InUseMask || ipc->u.Ills.I->ClRefCount)
1197 return;
1198 #ifdef DEBUG
1199 Yap_DirtyCps+=ipc->u.Ills.s;
1200 Yap_LiveCps-=ipc->u.Ills.s;
1201 #endif
1202 ipc = ipc->u.Ills.l1;
1203 /* in case we visit again */
1204 oipc->u.Ills.l1 = FAILCODE;
1205 oipc->u.Ills.s = 0;
1206 }
1207 break;
1208 case _try_in:
1209 case _jump:
1210 case _jump_if_var:
1211 ipc->u.l.l = release_wcls(ipc->u.l.l, ecs);
1212 ipc = NEXTOP(ipc,l);
1213 break;
1214 /* instructions type xl */
1215 case _jump_if_nonvar:
1216 ipc->u.xll.l1 = release_wcls(ipc->u.xll.l1, ecs);
1217 ipc = NEXTOP(ipc,xll);
1218 break;
1219 /* instructions type p */
1220 case _user_switch:
1221 ipc = NEXTOP(ipc,lp);
1222 break;
1223 /* instructions type e */
1224 case _switch_on_type:
1225 ipc->u.llll.l1 = release_wcls(ipc->u.llll.l1, ecs);
1226 ipc->u.llll.l2 = release_wcls(ipc->u.llll.l2, ecs);
1227 ipc->u.llll.l3 = release_wcls(ipc->u.llll.l3, ecs);
1228 ipc->u.llll.l4 = release_wcls(ipc->u.llll.l4, ecs);
1229 ipc = NEXTOP(ipc,llll);
1230 break;
1231 case _switch_list_nl:
1232 ipc->u.ollll.l1 = release_wcls(ipc->u.ollll.l1, ecs);
1233 ipc->u.ollll.l2 = release_wcls(ipc->u.ollll.l2, ecs);
1234 ipc->u.ollll.l3 = release_wcls(ipc->u.ollll.l3, ecs);
1235 ipc->u.ollll.l4 = release_wcls(ipc->u.ollll.l4, ecs);
1236 ipc = NEXTOP(ipc,ollll);
1237 break;
1238 case _switch_on_arg_type:
1239 ipc->u.xllll.l1 = release_wcls(ipc->u.xllll.l1, ecs);
1240 ipc->u.xllll.l2 = release_wcls(ipc->u.xllll.l2, ecs);
1241 ipc->u.xllll.l3 = release_wcls(ipc->u.xllll.l3, ecs);
1242 ipc->u.xllll.l4 = release_wcls(ipc->u.xllll.l4, ecs);
1243 ipc = NEXTOP(ipc,xllll);
1244 break;
1245 case _switch_on_sub_arg_type:
1246 ipc->u.sllll.l1 = release_wcls(ipc->u.sllll.l1, ecs);
1247 ipc->u.sllll.l2 = release_wcls(ipc->u.sllll.l2, ecs);
1248 ipc->u.sllll.l3 = release_wcls(ipc->u.sllll.l3, ecs);
1249 ipc->u.sllll.l4 = release_wcls(ipc->u.sllll.l4, ecs);
1250 ipc = NEXTOP(ipc,sllll);
1251 break;
1252 case _if_not_then:
1253 ipc = NEXTOP(ipc,clll);
1254 break;
1255 case _switch_on_func:
1256 case _if_func:
1257 case _go_on_func:
1258 case _switch_on_cons:
1259 case _if_cons:
1260 case _go_on_cons:
1261 /* make sure we don't leave dangling references to memory that is going to be removed */
1262 ipc->u.sssl.l = NULL;
1263 ipc = NEXTOP(ipc,sssl);
1264 break;
1265 case _op_fail:
1266 return;
1267 default:
1268 Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
1269 return;
1270 }
1271 #if defined(YAPOR) || defined(THREADS)
1272 ipc = (yamop *)((CELL)ipc & ~1);
1273 #endif
1274 }
1275 }
1276
1277 static void
decrease_log_indices(LogUpdIndex * c,yamop * suspend_code)1278 decrease_log_indices(LogUpdIndex *c, yamop *suspend_code)
1279 {
1280 /* decrease all reference counters */
1281 yamop *beg = c->ClCode, *end, *ipc;
1282 op_numbers op;
1283 if (c->ClFlags & SwitchTableMask) {
1284 CELL *end = (CELL *)((char *)c+c->ClSize);
1285 CELL *beg = (CELL *)(c->ClCode);
1286 OPCODE ecs = Yap_opcode(_expand_clauses);
1287
1288 while (beg < end) {
1289 yamop **x = (yamop **)(beg+1);
1290 beg += 2;
1291 *x = release_wcls(*x, ecs);
1292 }
1293 return;
1294 }
1295 op = Yap_op_from_opcode(beg->opc);
1296 end = (yamop *)((CODEADDR)c+c->ClSize);
1297 ipc = beg;
1298 cleanup_dangling_indices(ipc, beg, end, suspend_code);
1299 }
1300
1301 static void
kill_static_child_indxs(StaticIndex * indx,int in_use)1302 kill_static_child_indxs(StaticIndex *indx, int in_use)
1303 {
1304 StaticIndex *cl = indx->ChildIndex;
1305 while (cl != NULL) {
1306 StaticIndex *next = cl->SiblingIndex;
1307 kill_static_child_indxs(cl, in_use);
1308 cl = next;
1309 }
1310 if (in_use) {
1311 LOCK(DeadStaticIndicesLock);
1312 indx->SiblingIndex = DeadStaticIndices;
1313 indx->ChildIndex = NULL;
1314 DeadStaticIndices = indx;
1315 UNLOCK(DeadStaticIndicesLock);
1316 } else {
1317 Yap_InformOfRemoval((CODEADDR)indx);
1318 if (indx->ClFlags & SwitchTableMask)
1319 Yap_IndexSpace_SW -= indx->ClSize;
1320 else
1321 Yap_IndexSpace_Tree -= indx->ClSize;
1322 Yap_FreeCodeSpace((char *)indx);
1323 }
1324 }
1325
1326 static void
kill_children(LogUpdIndex * c,PredEntry * ap)1327 kill_children(LogUpdIndex *c, PredEntry *ap)
1328 {
1329 LogUpdIndex *ncl;
1330
1331 c->ClRefCount++;
1332 ncl = c->ChildIndex;
1333 /* kill children */
1334 while (ncl) {
1335 kill_first_log_iblock(ncl, c, ap);
1336 ncl = c->ChildIndex;
1337 }
1338 c->ClRefCount--;
1339 }
1340
1341
1342 /* assumes c is already locked */
1343 static void
kill_off_lu_block(LogUpdIndex * c,LogUpdIndex * parent,PredEntry * ap)1344 kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
1345 {
1346 /* first, make sure that I killed off all my children, some children may
1347 remain in case I have tables as children */
1348 if (parent != NULL) {
1349 /* sat bye bye */
1350 /* decrease refs */
1351 parent->ClRefCount--;
1352 if (parent->ClFlags & ErasedMask &&
1353 !(parent->ClFlags & InUseMask) &&
1354 parent->ClRefCount == 0) {
1355 /* cool, I can erase the father too. */
1356 if (parent->ClFlags & SwitchRootMask) {
1357 kill_off_lu_block(parent, NULL, ap);
1358 } else {
1359 kill_off_lu_block(parent, parent->ParentIndex, ap);
1360 }
1361 }
1362 }
1363 decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
1364 /* remove from list */
1365 if (c->SiblingIndex)
1366 c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
1367 if (c->PrevSiblingIndex) {
1368 c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
1369 } else {
1370 DBErasedIList = c->SiblingIndex;
1371 }
1372 Yap_InformOfRemoval((CODEADDR)c);
1373 if (c->ClFlags & SwitchTableMask)
1374 Yap_LUIndexSpace_SW -= c->ClSize;
1375 else {
1376 Yap_LUIndexSpace_Tree -= c->ClSize;
1377 }
1378 Yap_FreeCodeSpace((char *)c);
1379 }
1380
1381 static void
kill_first_log_iblock(LogUpdIndex * c,LogUpdIndex * parent,PredEntry * ap)1382 kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
1383 {
1384 /* parent is always locked, now I lock myself */
1385 if (parent != NULL) {
1386 /* remove myself from parent */
1387 if (c == parent->ChildIndex) {
1388 parent->ChildIndex = c->SiblingIndex;
1389 if (parent->ChildIndex) {
1390 parent->ChildIndex->PrevSiblingIndex = NULL;
1391 }
1392 } else {
1393 c->PrevSiblingIndex->SiblingIndex =
1394 c->SiblingIndex;
1395 if (c->SiblingIndex) {
1396 c->SiblingIndex->PrevSiblingIndex =
1397 c->PrevSiblingIndex;
1398 }
1399 }
1400 } else {
1401 /* I am top node */
1402 if (ap->cs.p_code.TrueCodeOfPred == c->ClCode) {
1403 RemoveMainIndex(ap);
1404 }
1405 }
1406 decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
1407 /* make sure that a child cannot remove us */
1408 kill_children(c, ap);
1409 /* check if we are still the main index */
1410 /* always add to erased list */
1411 c->SiblingIndex = DBErasedIList;
1412 c->PrevSiblingIndex = NULL;
1413 if (DBErasedIList)
1414 DBErasedIList->PrevSiblingIndex = c;
1415 DBErasedIList = c;
1416 if (!((c->ClFlags & InUseMask) || c->ClRefCount)) {
1417 kill_off_lu_block(c, parent, ap);
1418 } else {
1419 if (c->ClFlags & ErasedMask)
1420 return;
1421 c->ClFlags |= ErasedMask;
1422 /* try to move up, so that we don't hold a switch table */
1423 if (parent != NULL &&
1424 parent->ClFlags & SwitchTableMask) {
1425
1426 c->ParentIndex = parent->ParentIndex;
1427 parent->ParentIndex->ClRefCount++;
1428 parent->ClRefCount--;
1429 }
1430 }
1431 }
1432
1433 static void
kill_top_static_iblock(StaticIndex * c,PredEntry * ap)1434 kill_top_static_iblock(StaticIndex *c, PredEntry *ap)
1435 {
1436 kill_static_child_indxs(c, static_in_use(ap, TRUE));
1437 RemoveMainIndex(ap);
1438 }
1439
1440 void
Yap_kill_iblock(ClauseUnion * blk,ClauseUnion * parent_blk,PredEntry * ap)1441 Yap_kill_iblock(ClauseUnion *blk, ClauseUnion *parent_blk, PredEntry *ap)
1442 {
1443 if (ap->PredFlags & LogUpdatePredFlag) {
1444 LogUpdIndex *c = (LogUpdIndex *)blk;
1445 if (parent_blk != NULL) {
1446 LogUpdIndex *cl = (LogUpdIndex *)parent_blk;
1447 #if defined(THREADS) || defined(YAPOR)
1448 /* protect against attempts at erasing */
1449 cl->ClRefCount++;
1450 #endif
1451 kill_first_log_iblock(c, cl, ap);
1452 #if defined(THREADS) || defined(YAPOR)
1453 cl->ClRefCount--;
1454 #endif
1455 } else {
1456 kill_first_log_iblock(c, NULL, ap);
1457 }
1458 } else {
1459 StaticIndex *c = (StaticIndex *)blk;
1460 if (parent_blk != NULL) {
1461 StaticIndex *cl = parent_blk->si.ChildIndex;
1462 if (cl == c) {
1463 parent_blk->si.ChildIndex = c->SiblingIndex;
1464 } else {
1465 while (cl->SiblingIndex != c) {
1466 cl = cl->SiblingIndex;
1467 }
1468 cl->SiblingIndex = c->SiblingIndex;
1469 }
1470 }
1471 kill_static_child_indxs(c, static_in_use(ap, TRUE));
1472 }
1473 }
1474
1475 /*
1476 This predicate is supposed to be called with a
1477 lock on the current predicate
1478 */
1479 void
Yap_ErLogUpdIndex(LogUpdIndex * clau)1480 Yap_ErLogUpdIndex(LogUpdIndex *clau)
1481 {
1482 if (clau->ClFlags & ErasedMask) {
1483 if (!clau->ClRefCount) {
1484 decrease_log_indices(clau, (yamop *)&(clau->ClPred->cs.p_code.ExpandCode));
1485 if (clau->ClFlags & SwitchRootMask) {
1486 kill_off_lu_block(clau, NULL, clau->ClPred);
1487 } else {
1488 kill_off_lu_block(clau, clau->ParentIndex, clau->ClPred);
1489 }
1490 }
1491 /* otherwise, nothing I can do, I have been erased already */
1492 return;
1493 }
1494 if (clau->ClFlags & SwitchRootMask) {
1495 kill_first_log_iblock(clau, NULL, clau->ClPred);
1496 } else {
1497 #if defined(THREADS) || defined(YAPOR)
1498 /* protect against attempts at erasing */
1499 clau->ClRefCount++;
1500 #endif
1501 kill_first_log_iblock(clau, clau->ParentIndex, clau->ClPred);
1502 #if defined(THREADS) || defined(YAPOR)
1503 /* protect against attempts at erasing */
1504 clau->ClRefCount--;
1505 #endif
1506 }
1507 }
1508
1509 /* Routine used when wanting to remove the indexation */
1510 /* ap is known to already have been locked for WRITING */
1511 static int
RemoveIndexation(PredEntry * ap)1512 RemoveIndexation(PredEntry *ap)
1513 {
1514 if (ap->OpcodeOfPred == INDEX_OPCODE) {
1515 return TRUE;
1516 }
1517 if (ap->PredFlags & LogUpdatePredFlag) {
1518 kill_first_log_iblock(ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred), NULL, ap);
1519 } else {
1520 StaticIndex *cl;
1521
1522 cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
1523
1524 kill_top_static_iblock(cl, ap);
1525
1526 }
1527 return TRUE;
1528 }
1529
1530 int
Yap_RemoveIndexation(PredEntry * ap)1531 Yap_RemoveIndexation(PredEntry *ap)
1532 {
1533 return RemoveIndexation(ap);
1534 }
1535 /******************************************************************
1536
1537 Adding clauses
1538
1539 ******************************************************************/
1540
1541
1542 #define assertz 0
1543 #define consult 1
1544 #define asserta 2
1545
1546 /* p is already locked */
1547 static void
retract_all(PredEntry * p,int in_use)1548 retract_all(PredEntry *p, int in_use)
1549 {
1550 yamop *q;
1551
1552 q = p->cs.p_code.FirstClause;
1553 if (q != NULL) {
1554 if (p->PredFlags & LogUpdatePredFlag) {
1555 LogUpdClause *cl = ClauseCodeToLogUpdClause(q);
1556 do {
1557 LogUpdClause *ncl = cl->ClNext;
1558 Yap_ErLogUpdCl(cl);
1559 cl = ncl;
1560 } while (cl != NULL);
1561 } else if (p->PredFlags & MegaClausePredFlag) {
1562 MegaClause *cl = ClauseCodeToMegaClause(q);
1563
1564 if (in_use || cl->ClFlags & HasBlobsMask) {
1565 LOCK(DeadMegaClausesLock);
1566 cl->ClNext = DeadMegaClauses;
1567 DeadMegaClauses = cl;
1568 UNLOCK(DeadMegaClausesLock);
1569 } else {
1570 Yap_InformOfRemoval((CODEADDR)cl);
1571 Yap_ClauseSpace -= cl->ClSize;
1572 Yap_FreeCodeSpace((char *)cl);
1573 }
1574 /* make sure this is not a MegaClause */
1575 p->PredFlags &= ~MegaClausePredFlag;
1576 p->cs.p_code.NOfClauses = 0;
1577 } else {
1578 StaticClause *cl = ClauseCodeToStaticClause(q);
1579
1580 while (cl) {
1581 StaticClause *ncl = cl->ClNext;
1582
1583 if (in_use|| cl->ClFlags & HasBlobsMask) {
1584 LOCK(DeadStaticClausesLock);
1585 cl->ClNext = DeadStaticClauses;
1586 DeadStaticClauses = cl;
1587 UNLOCK(DeadStaticClausesLock);
1588 } else {
1589 Yap_InformOfRemoval((CODEADDR)cl);
1590 Yap_ClauseSpace -= cl->ClSize;
1591 Yap_FreeCodeSpace((char *)cl);
1592 }
1593 p->cs.p_code.NOfClauses--;
1594 if (!ncl) break;
1595 cl = ncl;
1596 }
1597 }
1598 }
1599 p->cs.p_code.FirstClause = NULL;
1600 p->cs.p_code.LastClause = NULL;
1601 if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag)) {
1602 p->OpcodeOfPred = FAIL_OPCODE;
1603 } else {
1604 p->OpcodeOfPred = UNDEF_OPCODE;
1605 }
1606 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1607 #if defined(YAPOR) || defined(THREADS)
1608 if (p->PredFlags & LogUpdatePredFlag &&
1609 p->ModuleOfPred != IDB_MODULE) {
1610 p->OpcodeOfPred = LOCKPRED_OPCODE;
1611 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1612 }
1613 #endif
1614 p->StatisticsForPred.NOfEntries = 0;
1615 p->StatisticsForPred.NOfHeadSuccesses = 0;
1616 p->StatisticsForPred.NOfRetries = 0;
1617 if (PROFILING) {
1618 p->PredFlags |= ProfiledPredFlag;
1619 } else
1620 p->PredFlags &= ~ProfiledPredFlag;
1621 if (CALL_COUNTING) {
1622 p->PredFlags |= CountPredFlag;
1623 } else
1624 p->PredFlags &= ~CountPredFlag;
1625 #ifdef YAPOR
1626 if (SEQUENTIAL_IS_DEFAULT) {
1627 p->PredFlags |= SequentialPredFlag;
1628 }
1629 #endif /* YAPOR */
1630 Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
1631 }
1632
1633 /* p is already locked */
1634 static void
add_first_static(PredEntry * p,yamop * cp,int spy_flag)1635 add_first_static(PredEntry *p, yamop *cp, int spy_flag)
1636 {
1637 yamop *pt = cp;
1638
1639 if (is_logupd(p)) {
1640 if (p == PredGoalExpansion) {
1641 PRED_GOAL_EXPANSION_ON = TRUE;
1642 Yap_InitComma();
1643 }
1644 } else {
1645 #ifdef YAPOR
1646 if (SEQUENTIAL_IS_DEFAULT) {
1647 p->PredFlags |= SequentialPredFlag;
1648 }
1649 #endif /* YAPOR */
1650 #ifdef TABLING
1651 if (is_tabled(p)) {
1652 p->OpcodeOfPred = INDEX_OPCODE;
1653 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1654 }
1655 #endif /* TABLING */
1656 }
1657 p->cs.p_code.TrueCodeOfPred = pt;
1658 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = cp;
1659 p->OpcodeOfPred = pt->opc;
1660 #if defined(YAPOR) || defined(THREADS)
1661 if (p->PredFlags & LogUpdatePredFlag &&
1662 p->ModuleOfPred != IDB_MODULE) {
1663 p->OpcodeOfPred = LOCKPRED_OPCODE;
1664 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1665 } else
1666 #endif
1667 p->CodeOfPred = pt;
1668 p->cs.p_code.NOfClauses = 1;
1669 p->StatisticsForPred.NOfEntries = 0;
1670 p->StatisticsForPred.NOfHeadSuccesses = 0;
1671 p->StatisticsForPred.NOfRetries = 0;
1672 if (PROFILING) {
1673 p->PredFlags |= ProfiledPredFlag;
1674 spy_flag = TRUE;
1675 } else {
1676 p->PredFlags &= ~ProfiledPredFlag;
1677 }
1678 if (CALL_COUNTING) {
1679 p->PredFlags |= CountPredFlag;
1680 spy_flag = TRUE;
1681 } else {
1682 p->PredFlags &= ~CountPredFlag;
1683 }
1684 if (spy_flag) {
1685 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1686 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1687 }
1688 if ((yap_flags[SOURCE_MODE_FLAG] ||
1689 (p->PredFlags & MultiFileFlag)) &&
1690 !(p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
1691 p->PredFlags |= SourcePredFlag;
1692 } else {
1693 p->PredFlags &= ~SourcePredFlag;
1694 }
1695 }
1696
1697 /* p is already locked */
1698 static void
add_first_dynamic(PredEntry * p,yamop * cp,int spy_flag)1699 add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag)
1700 {
1701 yamop *ncp = ((DynamicClause *)NULL)->ClCode;
1702 DynamicClause *cl;
1703 if (p == PredGoalExpansion) {
1704 PRED_GOAL_EXPANSION_ON = TRUE;
1705 Yap_InitComma();
1706 }
1707 p->StatisticsForPred.NOfEntries = 0;
1708 p->StatisticsForPred.NOfHeadSuccesses = 0;
1709 p->StatisticsForPred.NOfRetries = 0;
1710 if (PROFILING) {
1711 p->PredFlags |= ProfiledPredFlag;
1712 spy_flag = TRUE;
1713 } else {
1714 p->PredFlags &= ~ProfiledPredFlag;
1715 }
1716 if (CALL_COUNTING) {
1717 p->PredFlags |= CountPredFlag;
1718 spy_flag = TRUE;
1719 } else {
1720 p->PredFlags &= ~CountPredFlag;
1721 }
1722 #ifdef YAPOR
1723 p->PredFlags |= SequentialPredFlag;
1724 #endif /* YAPOR */
1725 /* allocate starter block, containing info needed to start execution,
1726 * that is a try_mark to start the code and a fail to finish things up */
1727 cl =
1728 (DynamicClause *) Yap_AllocCodeSpace((Int)NEXTOP(NEXTOP(NEXTOP(ncp,Otapl),e),l));
1729 if (cl == NIL) {
1730 Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"Heap crashed against Stacks");
1731 return;
1732 }
1733 Yap_ClauseSpace += (Int)NEXTOP(NEXTOP(NEXTOP(ncp,Otapl),e),l);
1734 /* skip the first entry, this contains the back link and will always be
1735 empty for this entry */
1736 ncp = (yamop *)(((CELL *)ncp)+1);
1737 /* next we have the flags. For this block mainly say whether we are
1738 * being spied */
1739 cl->ClFlags = DynamicMask;
1740 ncp = cl->ClCode;
1741 INIT_LOCK(cl->ClLock);
1742 INIT_CLREF_COUNT(cl);
1743 /* next, set the first instruction to execute in the dyamic
1744 * predicate */
1745 if (spy_flag)
1746 p->OpcodeOfPred = ncp->opc = Yap_opcode(_spy_or_trymark);
1747 else
1748 p->OpcodeOfPred = ncp->opc = Yap_opcode(_try_and_mark);
1749 ncp->u.Otapl.s = p->ArityOfPE;
1750 ncp->u.Otapl.p = p;
1751 ncp->u.Otapl.d = cp;
1752 /* This is the point we enter the code */
1753 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = ncp;
1754 p->cs.p_code.NOfClauses = 1;
1755 #if defined(YAPOR) || defined(THREADS)
1756 if (p->PredFlags & LogUpdatePredFlag &&
1757 p->ModuleOfPred != IDB_MODULE) {
1758 p->OpcodeOfPred = LOCKPRED_OPCODE;
1759 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1760 }
1761 #endif
1762 /* set the first clause to have a retry and mark which will
1763 * backtrack to the previous block */
1764 if (p->PredFlags & ProfiledPredFlag)
1765 cp->opc = Yap_opcode(_profiled_retry_and_mark);
1766 else if (p->PredFlags & CountPredFlag)
1767 cp->opc = Yap_opcode(_count_retry_and_mark);
1768 else
1769 cp->opc = Yap_opcode(_retry_and_mark);
1770 cp->u.Otapl.s = p->ArityOfPE;
1771 cp->u.Otapl.p = p;
1772 cp->u.Otapl.d = ncp;
1773 /* also, keep a backpointer for the days you delete the clause */
1774 ClauseCodeToDynamicClause(cp)->ClPrevious = ncp;
1775 /* Don't forget to say who is the only clause for the predicate so
1776 far */
1777 p->cs.p_code.LastClause = p->cs.p_code.FirstClause = cp;
1778 /* we're only missing what to do when we actually exit the procedure
1779 */
1780 ncp = NEXTOP(ncp,Otapl);
1781 /* and the last instruction to execute to exit the predicate, note
1782 the retry is pointing to this pseudo clause */
1783 ncp->opc = Yap_opcode(_trust_fail);
1784 /* we're only missing what to do when we actually exit the procedure
1785 */
1786 /* and close the code */
1787 ncp = NEXTOP(ncp,e);
1788 ncp->opc = Yap_opcode(_Ystop);
1789 ncp->u.l.l = cl->ClCode;
1790 }
1791
1792 /* p is already locked */
1793 static void
asserta_stat_clause(PredEntry * p,yamop * q,int spy_flag)1794 asserta_stat_clause(PredEntry *p, yamop *q, int spy_flag)
1795 {
1796 StaticClause *cl = ClauseCodeToStaticClause(q);
1797
1798 p->cs.p_code.NOfClauses++;
1799 if (is_logupd(p)) {
1800 LogUpdClause
1801 *clp = ClauseCodeToLogUpdClause(p->cs.p_code.FirstClause),
1802 *clq = ClauseCodeToLogUpdClause(q);
1803 clq->ClPrev = NULL;
1804 clq->ClNext = clp;
1805 clp->ClPrev = clq;
1806 p->cs.p_code.FirstClause = q;
1807 if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
1808 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1809 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1810 } else if (!(p->PredFlags & IndexedPredFlag)) {
1811 p->OpcodeOfPred = INDEX_OPCODE;
1812 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1813 }
1814 #if defined(YAPOR) || defined(THREADS)
1815 if (p->ModuleOfPred != IDB_MODULE) {
1816 p->OpcodeOfPred = LOCKPRED_OPCODE;
1817 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1818 }
1819 #endif
1820 return;
1821 }
1822 cl->ClNext = ClauseCodeToStaticClause(p->cs.p_code.FirstClause);
1823 p->cs.p_code.FirstClause = q;
1824 p->cs.p_code.TrueCodeOfPred = q;
1825 if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
1826 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1827 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1828 } else if (!(p->PredFlags & IndexedPredFlag)) {
1829 p->OpcodeOfPred = INDEX_OPCODE;
1830 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1831 }
1832 p->cs.p_code.LastClause->u.Otapl.d = q;
1833 }
1834
1835 /* p is already locked */
1836 static void
asserta_dynam_clause(PredEntry * p,yamop * cp)1837 asserta_dynam_clause(PredEntry *p, yamop *cp)
1838 {
1839 yamop *q;
1840 DynamicClause *cl = ClauseCodeToDynamicClause(cp);
1841 q = cp;
1842 LOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
1843 /* also, keep backpointers for the days we'll delete all the clause */
1844 ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClPrevious = q;
1845 cl->ClPrevious = (yamop *)(p->CodeOfPred);
1846 cl->ClFlags |= DynamicMask;
1847 UNLOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
1848 q->u.Otapl.d = p->cs.p_code.FirstClause;
1849 q->u.Otapl.s = p->ArityOfPE;
1850 q->u.Otapl.p = p;
1851 if (p->PredFlags & ProfiledPredFlag)
1852 cp->opc = Yap_opcode(_profiled_retry_and_mark);
1853 else if (p->PredFlags & CountPredFlag)
1854 cp->opc = Yap_opcode(_count_retry_and_mark);
1855 else
1856 cp->opc = Yap_opcode(_retry_and_mark);
1857 cp->u.Otapl.s = p->ArityOfPE;
1858 cp->u.Otapl.p = p;
1859 p->cs.p_code.FirstClause = cp;
1860 q = p->CodeOfPred;
1861 q->u.Otapl.d = cp;
1862 q->u.Otapl.s = p->ArityOfPE;
1863 q->u.Otapl.p = p;
1864
1865 }
1866
1867 /* p is already locked */
1868 static void
assertz_stat_clause(PredEntry * p,yamop * cp,int spy_flag)1869 assertz_stat_clause(PredEntry *p, yamop *cp, int spy_flag)
1870 {
1871 yamop *pt;
1872
1873 p->cs.p_code.NOfClauses++;
1874 pt = p->cs.p_code.LastClause;
1875 if (is_logupd(p)) {
1876 LogUpdClause
1877 *clp = ClauseCodeToLogUpdClause(cp),
1878 *clq = ClauseCodeToLogUpdClause(pt);
1879
1880 clq->ClNext = clp;
1881 clp->ClPrev = clq;
1882 clp->ClNext = NULL;
1883 p->cs.p_code.LastClause = cp;
1884 if (!(p->PredFlags & IndexedPredFlag)) {
1885 p->OpcodeOfPred = INDEX_OPCODE;
1886 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1887 }
1888 #if defined(YAPOR) || defined(THREADS)
1889 if (p->ModuleOfPred != IDB_MODULE) {
1890 p->OpcodeOfPred = LOCKPRED_OPCODE;
1891 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1892 }
1893 #endif
1894 if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
1895 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1896 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1897 }
1898 return;
1899 } else {
1900 StaticClause *cl = ClauseCodeToStaticClause(pt);
1901
1902 cl->ClNext = ClauseCodeToStaticClause(cp);
1903 }
1904 if (p->cs.p_code.FirstClause == p->cs.p_code.LastClause) {
1905 if (!(p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag))) {
1906 p->OpcodeOfPred = INDEX_OPCODE;
1907 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1908 }
1909 }
1910 p->cs.p_code.LastClause = cp;
1911 }
1912
1913 /* p is already locked */
1914 static void
assertz_dynam_clause(PredEntry * p,yamop * cp)1915 assertz_dynam_clause(PredEntry *p, yamop *cp)
1916 {
1917 yamop *q;
1918 DynamicClause *cl = ClauseCodeToDynamicClause(cp);
1919
1920 q = p->cs.p_code.LastClause;
1921 LOCK(ClauseCodeToDynamicClause(q)->ClLock);
1922 q->u.Otapl.d = cp;
1923 p->cs.p_code.LastClause = cp;
1924 /* also, keep backpointers for the days we'll delete all the clause */
1925 cl->ClPrevious = q;
1926 cl->ClFlags |= DynamicMask;
1927 UNLOCK(ClauseCodeToDynamicClause(q)->ClLock);
1928 q = (yamop *)cp;
1929 if (p->PredFlags & ProfiledPredFlag)
1930 q->opc = Yap_opcode(_profiled_retry_and_mark);
1931 else if (p->PredFlags & CountPredFlag)
1932 q->opc = Yap_opcode(_count_retry_and_mark);
1933 else
1934 q->opc = Yap_opcode(_retry_and_mark);
1935 q->u.Otapl.d = p->CodeOfPred;
1936 q->u.Otapl.s = p->ArityOfPE;
1937 q->u.Otapl.p = p;
1938 p->cs.p_code.NOfClauses++;
1939 }
1940
expand_consult(void)1941 static void expand_consult(void)
1942 {
1943 consult_obj *new_cl, *new_cs;
1944 UInt OldConsultCapacity = ConsultCapacity;
1945
1946 /* now double consult capacity */
1947 ConsultCapacity += InitialConsultCapacity;
1948 /* I assume it always works ;-) */
1949 while ((new_cl = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*ConsultCapacity)) == NULL) {
1950 if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) {
1951 Yap_Error(OUT_OF_HEAP_ERROR,TermNil,Yap_ErrorMessage);
1952 return;
1953 }
1954 }
1955 new_cs = new_cl + InitialConsultCapacity;
1956 /* start copying */
1957 memcpy((void *)new_cs, (void *)ConsultLow, OldConsultCapacity*sizeof(consult_obj));
1958 /* copying done, release old space */
1959 Yap_FreeCodeSpace((char *)ConsultLow);
1960 /* next, set up pointers correctly */
1961 new_cs += (ConsultSp-ConsultLow);
1962 /* put ConsultBase at same offset as before move */
1963 ConsultBase = ConsultBase+(new_cs-ConsultSp);
1964 /* new consult pointer */
1965 ConsultSp = new_cs;
1966 /* new end of memory */
1967 ConsultLow = new_cl;
1968 }
1969
1970 /* p was already locked */
1971 static int
not_was_reconsulted(PredEntry * p,Term t,int mode)1972 not_was_reconsulted(PredEntry *p, Term t, int mode)
1973 {
1974 register consult_obj *fp;
1975 Prop p0 = AbsProp((PropEntry *)p);
1976
1977 if (p == LastAssertedPred)
1978 return FALSE;
1979 LastAssertedPred = p;
1980 if (!ConsultSp) {
1981 InitConsultStack();
1982 }
1983 if (p->cs.p_code.NOfClauses) {
1984 for (fp = ConsultSp; fp < ConsultBase; ++fp)
1985 if (fp->p == p0)
1986 break;
1987 } else {
1988 fp = ConsultBase;
1989 }
1990 if (fp != ConsultBase)
1991 return FALSE;
1992 if (mode) {
1993 if (ConsultSp == ConsultLow+1) {
1994 expand_consult();
1995 }
1996 --ConsultSp;
1997 ConsultSp->p = p0;
1998 if (ConsultBase[1].mode &&
1999 !(p->PredFlags & MultiFileFlag)) /* we are in reconsult mode */ {
2000 retract_all(p, static_in_use(p,TRUE));
2001 }
2002 p->src.OwnerFile = YapConsultingFile();
2003 }
2004 return TRUE; /* careful */
2005 }
2006
2007 static void
addcl_permission_error(AtomEntry * ap,Int Arity,int in_use)2008 addcl_permission_error(AtomEntry *ap, Int Arity, int in_use)
2009 {
2010 Term t, ti[2];
2011
2012 ti[0] = MkAtomTerm(AbsAtom(ap));
2013 ti[1] = MkIntegerTerm(Arity);
2014 t = Yap_MkApplTerm(FunctorSlash, 2, ti);
2015 Yap_ErrorMessage = Yap_ErrorSay;
2016 Yap_Error_Term = t;
2017 Yap_Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
2018 if (in_use) {
2019 if (Arity == 0)
2020 sprintf(Yap_ErrorMessage, "static predicate %s is in use", ap->StrOfAE);
2021 else
2022 sprintf(Yap_ErrorMessage,
2023 "static predicate %s/" Int_FORMAT " is in use",
2024 ap->StrOfAE, Arity);
2025 } else {
2026 if (Arity == 0)
2027 sprintf(Yap_ErrorMessage, "system predicate %s", ap->StrOfAE);
2028 else
2029 sprintf(Yap_ErrorMessage,
2030 "system predicate %s/" Int_FORMAT,
2031 ap->StrOfAE, Arity);
2032 }
2033 }
2034
2035
2036 static int
is_fact(Term t)2037 is_fact(Term t)
2038 {
2039 Term a1;
2040
2041 if (IsAtomTerm(t))
2042 return TRUE;
2043 if (FunctorOfTerm(t) != FunctorAssert)
2044 return TRUE;
2045 a1 = ArgOfTerm(2, t);
2046 if (a1 == MkAtomTerm(AtomTrue))
2047 return TRUE;
2048 return FALSE;
2049 }
2050
2051 static void
mark_preds_with_this_func(Functor f,Prop p0)2052 mark_preds_with_this_func(Functor f, Prop p0)
2053 {
2054 PredEntry *pe = RepPredProp(p0);
2055 UInt i;
2056
2057 pe->PredFlags |= GoalExPredFlag;
2058 for (i = 0; i < PredHashTableSize; i++) {
2059 PredEntry *p = PredHash[i];
2060
2061 while (p) {
2062 Prop nextp = p->NextOfPE;
2063 if (p->FunctorOfPred == f)
2064 p->PredFlags |= GoalExPredFlag;
2065 p = RepPredProp(nextp);
2066 }
2067 }
2068 }
2069
2070
2071 static int
addclause(Term t,yamop * cp,int mode,Term mod,Term * t4ref)2072 addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref)
2073 /*
2074 *
2075 mode
2076 0 assertz
2077 1 consult
2078 2 asserta
2079 */
2080 {
2081 PredEntry *p;
2082 int spy_flag = FALSE;
2083 Atom at;
2084 UInt Arity;
2085 CELL pflags;
2086 Term tf;
2087
2088
2089 if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
2090 tf = ArgOfTerm(1, t);
2091 else
2092 tf = t;
2093 if (IsAtomTerm(tf)) {
2094 at = AtomOfTerm(tf);
2095 p = RepPredProp(PredPropByAtom(at, mod));
2096 Arity = 0;
2097 } else {
2098 Functor f = FunctorOfTerm(tf);
2099 Arity = ArityOfFunctor(f);
2100 at = NameOfFunctor(f);
2101 p = RepPredProp(PredPropByFunc(f, mod));
2102 }
2103 Yap_PutValue(AtomAbol, TermNil);
2104 PELOCK(20,p);
2105 pflags = p->PredFlags;
2106 /* we are redefining a prolog module predicate */
2107 if ((pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) ||
2108 (p->ModuleOfPred == PROLOG_MODULE &&
2109 mod != TermProlog && mod) ) {
2110 addcl_permission_error(RepAtom(at), Arity, FALSE);
2111 UNLOCKPE(30,p);
2112 return TermNil;
2113 }
2114 /* we are redefining a prolog module predicate */
2115 if (pflags & MegaClausePredFlag) {
2116 split_megaclause(p);
2117 }
2118 /* The only problem we have now is when we need to throw away
2119 Indexing blocks
2120 */
2121 if (pflags & IndexedPredFlag) {
2122 Yap_AddClauseToIndex(p, cp, mode == asserta);
2123 }
2124 if (pflags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag))
2125 spy_flag = TRUE;
2126 if (p == PredGoalExpansion) {
2127 Term tg = ArgOfTerm(1, tf);
2128 Term tm = ArgOfTerm(2, tf);
2129
2130 if (IsVarTerm(tg) || IsVarTerm(tm)) {
2131 if (!IsVarTerm(tg)) {
2132 /* this is the complicated case, first I need to inform
2133 predicates for this functor */
2134 PRED_GOAL_EXPANSION_FUNC = TRUE;
2135 if (IsAtomTerm(tg)) {
2136 AtomEntry *ae = RepAtom(AtomOfTerm(tg));
2137 Prop p0 = ae->PropsOfAE;
2138 int found = FALSE;
2139
2140 while (p0) {
2141 PredEntry *pe = RepPredProp(p0);
2142 if (pe->KindOfPE == PEProp) {
2143 pe->PredFlags |= GoalExPredFlag;
2144 found = TRUE;
2145 }
2146 p0 = pe->NextOfPE;
2147 }
2148 if (!found) {
2149 PredEntry *npe = RepPredProp(PredPropByAtom(AtomOfTerm(tg),IDB_MODULE));
2150 npe->PredFlags |= GoalExPredFlag;
2151 }
2152 } else if (IsApplTerm(tg)) {
2153 FunctorEntry *fe = (FunctorEntry *)FunctorOfTerm(tg);
2154 Prop p0;
2155
2156 p0 = fe->PropsOfFE;
2157 if (p0) {
2158 mark_preds_with_this_func(FunctorOfTerm(tg), p0);
2159 } else {
2160 Term mod = CurrentModule;
2161 PredEntry *npe;
2162 if (CurrentModule == PROLOG_MODULE)
2163 mod = IDB_MODULE;
2164 npe = RepPredProp(PredPropByFunc(fe,mod));
2165 npe->PredFlags |= GoalExPredFlag;
2166 }
2167 }
2168 } else {
2169 PRED_GOAL_EXPANSION_ALL = TRUE;
2170 }
2171 } else {
2172 if (IsAtomTerm(tm)) {
2173 if (IsAtomTerm(tg)) {
2174 PredEntry *p = RepPredProp(PredPropByAtom(AtomOfTerm(tg), tm));
2175 p->PredFlags |= GoalExPredFlag;
2176 } else if (IsApplTerm(tg)) {
2177 PredEntry *p = RepPredProp(PredPropByFunc(FunctorOfTerm(tg), tm));
2178 p->PredFlags |= GoalExPredFlag;
2179 }
2180 }
2181 }
2182 }
2183 if (mode == consult)
2184 not_was_reconsulted(p, t, TRUE);
2185 /* always check if we have a valid error first */
2186 if (Yap_ErrorMessage && Yap_Error_TYPE == PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE) {
2187 UNLOCKPE(31,p);
2188 return TermNil;
2189 }
2190 if (pflags & UDIPredFlag) {
2191 Yap_new_udi_clause(p, cp, t);
2192 }
2193 if (!is_dynamic(p)) {
2194 if (pflags & LogUpdatePredFlag) {
2195 LogUpdClause *clp = ClauseCodeToLogUpdClause(cp);
2196 clp->ClFlags |= LogUpdMask;
2197 if (is_fact(t)) {
2198 clp->ClFlags |= FactMask;
2199 clp->ClSource = NULL;
2200 }
2201 } else {
2202 StaticClause *clp = ClauseCodeToStaticClause(cp);
2203 clp->ClFlags |= StaticMask;
2204 if (is_fact(t) && !(p->PredFlags & TabledPredFlag)) {
2205 clp->ClFlags |= FactMask;
2206 clp->usc.ClPred = p;
2207 }
2208 }
2209 if (compile_mode)
2210 p->PredFlags = p->PredFlags | CompiledPredFlag;
2211 else
2212 p->PredFlags = p->PredFlags | CompiledPredFlag;
2213 }
2214 if (p->cs.p_code.FirstClause == NULL) {
2215 if (!(pflags & DynamicPredFlag)) {
2216 add_first_static(p, cp, spy_flag);
2217 /* make sure we have a place to jump to */
2218 if (p->OpcodeOfPred == UNDEF_OPCODE ||
2219 p->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
2220 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
2221 p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
2222 }
2223 #if defined(YAPOR) || defined(THREADS)
2224 if (p->PredFlags & LogUpdatePredFlag &&
2225 p->ModuleOfPred != IDB_MODULE) {
2226 p->OpcodeOfPred = LOCKPRED_OPCODE;
2227 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
2228 }
2229 #endif
2230 } else {
2231 add_first_dynamic(p, cp, spy_flag);
2232 }
2233 } else if (mode == asserta) {
2234 if (pflags & DynamicPredFlag)
2235 asserta_dynam_clause(p, cp);
2236 else
2237 asserta_stat_clause(p, cp, spy_flag);
2238 } else if (pflags & DynamicPredFlag)
2239 assertz_dynam_clause(p, cp);
2240 else {
2241 assertz_stat_clause(p, cp, spy_flag);
2242 if (p->OpcodeOfPred != INDEX_OPCODE &&
2243 p->OpcodeOfPred != Yap_opcode(_spy_pred)) {
2244 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
2245 p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
2246 }
2247 #if defined(YAPOR) || defined(THREADS)
2248 if (p->PredFlags & LogUpdatePredFlag &&
2249 p->ModuleOfPred != IDB_MODULE) {
2250 p->OpcodeOfPred = LOCKPRED_OPCODE;
2251 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
2252 }
2253 #endif
2254 }
2255 UNLOCKPE(32,p);
2256 if (pflags & LogUpdatePredFlag) {
2257 LogUpdClause *cl = (LogUpdClause *)ClauseCodeToLogUpdClause(cp);
2258 tf = MkDBRefTerm((DBRef)cl);
2259 #if defined(YAPOR) || defined(THREADS)
2260 TRAIL_CLREF(cl); /* So that fail will erase it */
2261 INC_CLREF_COUNT(cl);
2262 #else
2263 if (!(cl->ClFlags & InUseMask)) {
2264 cl->ClFlags |= InUseMask;
2265 TRAIL_CLREF(cl); /* So that fail will erase it */
2266 }
2267 #endif
2268 } else {
2269 tf = Yap_MkStaticRefTerm(ClauseCodeToStaticClause(cp));
2270 }
2271 if (*t4ref != TermNil) {
2272 if (!Yap_unify(*t4ref,tf)) {
2273 return FALSE;
2274 }
2275 }
2276 if (pflags & MultiFileFlag) {
2277 /* add Info on new clause for multifile predicates to the DB */
2278 Term t[5], tn;
2279 t[0] = MkAtomTerm(YapConsultingFile());
2280 t[1] = MkAtomTerm(at);
2281 t[2] = MkIntegerTerm(Arity);
2282 t[3] = mod;
2283 t[4] = tf;
2284 tn = Yap_MkApplTerm(FunctorMultiFileClause,5,t);
2285 Yap_Recordz(AtomMultiFile,tn);
2286 }
2287 return TRUE;
2288 }
2289
2290 int
Yap_addclause(Term t,yamop * cp,int mode,Term mod,Term * t4ref)2291 Yap_addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref) {
2292 return addclause(t, cp, mode, mod, t4ref);
2293 }
2294
2295 void
Yap_EraseMegaClause(yamop * cl,PredEntry * ap)2296 Yap_EraseMegaClause(yamop *cl,PredEntry *ap) {
2297 /* just make it fail */
2298 cl->opc = Yap_opcode(_op_fail);
2299 }
2300
2301 void
Yap_EraseStaticClause(StaticClause * cl,Term mod)2302 Yap_EraseStaticClause(StaticClause *cl, Term mod) {
2303 PredEntry *ap;
2304
2305 /* ok, first I need to find out the parent predicate */
2306 if (cl->ClFlags & FactMask) {
2307 ap = cl->usc.ClPred;
2308 } else {
2309 Term t = ArgOfTerm(1,cl->usc.ClSource->Entry);
2310 if (IsAtomTerm(t)) {
2311 Atom at = AtomOfTerm(t);
2312 ap = RepPredProp(Yap_GetPredPropByAtom(at, mod));
2313 } else {
2314 Functor fun = FunctorOfTerm(t);
2315 ap = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
2316 }
2317 }
2318 if (ap->PredFlags & MegaClausePredFlag) {
2319 split_megaclause(ap);
2320 }
2321 if (ap->PredFlags & IndexedPredFlag)
2322 RemoveIndexation(ap);
2323 ap->cs.p_code.NOfClauses--;
2324 if (ap->cs.p_code.FirstClause == cl->ClCode) {
2325 /* got rid of first clause */
2326 if (ap->cs.p_code.LastClause == cl->ClCode) {
2327 /* got rid of all clauses */
2328 ap->cs.p_code.LastClause = ap->cs.p_code.FirstClause = NULL;
2329 ap->OpcodeOfPred = UNDEF_OPCODE;
2330 ap->cs.p_code.TrueCodeOfPred =
2331 (yamop *)(&(ap->OpcodeOfPred));
2332 } else {
2333 yamop *ncl = cl->ClNext->ClCode;
2334 ap->cs.p_code.FirstClause = ncl;
2335 ap->cs.p_code.TrueCodeOfPred =
2336 ncl;
2337 ap->OpcodeOfPred = ncl->opc;
2338 }
2339 } else {
2340 StaticClause *pcl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause),
2341 *ocl = NULL;
2342
2343 while (pcl != cl) {
2344 ocl = pcl;
2345 pcl = pcl->ClNext;
2346 }
2347 ocl->ClNext = cl->ClNext;
2348 if (cl->ClCode == ap->cs.p_code.LastClause) {
2349 ap->cs.p_code.LastClause = ocl->ClCode;
2350 }
2351 }
2352 if (ap->cs.p_code.NOfClauses == 1) {
2353 ap->cs.p_code.TrueCodeOfPred =
2354 ap->cs.p_code.FirstClause;
2355 ap->OpcodeOfPred =
2356 ap->cs.p_code.TrueCodeOfPred->opc;
2357 }
2358 if (cl->ClFlags & HasBlobsMask || static_in_use(ap,TRUE)) {
2359 LOCK(DeadStaticClausesLock);
2360 cl->ClNext = DeadStaticClauses;
2361 DeadStaticClauses = cl;
2362 UNLOCK(DeadStaticClausesLock);
2363 } else {
2364 Yap_InformOfRemoval((CODEADDR)cl);
2365 Yap_ClauseSpace -= cl->ClSize;
2366 Yap_FreeCodeSpace((char *)cl);
2367 }
2368 if (ap->cs.p_code.NOfClauses == 0) {
2369 ap->CodeOfPred =
2370 ap->cs.p_code.TrueCodeOfPred;
2371 } else if (ap->cs.p_code.NOfClauses > 1) {
2372 ap->OpcodeOfPred = INDEX_OPCODE;
2373 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
2374 } else if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
2375 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
2376 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
2377 } else {
2378 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
2379 }
2380 #if defined(YAPOR) || defined(THREADS)
2381 if (ap->PredFlags & LogUpdatePredFlag &&
2382 ap->ModuleOfPred != IDB_MODULE) {
2383 ap->OpcodeOfPred = LOCKPRED_OPCODE;
2384 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
2385 }
2386 #endif
2387 }
2388
2389 void
Yap_add_logupd_clause(PredEntry * pe,LogUpdClause * cl,int mode)2390 Yap_add_logupd_clause(PredEntry *pe, LogUpdClause *cl, int mode) {
2391 yamop *cp = cl->ClCode;
2392
2393 if (pe->PredFlags & IndexedPredFlag) {
2394 Yap_AddClauseToIndex(pe, cp, mode == asserta);
2395 }
2396 if (pe->cs.p_code.FirstClause == NULL) {
2397 add_first_static(pe, cp, FALSE);
2398 /* make sure we have a place to jump to */
2399 if (pe->OpcodeOfPred == UNDEF_OPCODE ||
2400 pe->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
2401 #if defined(YAPOR) || defined(THREADS)
2402 if (pe->PredFlags & LogUpdatePredFlag &&
2403 pe->ModuleOfPred != IDB_MODULE) {
2404 pe->OpcodeOfPred = LOCKPRED_OPCODE;
2405 pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
2406 } else {
2407 #endif
2408 pe->CodeOfPred = pe->cs.p_code.TrueCodeOfPred;
2409 pe->OpcodeOfPred = ((yamop *)(pe->CodeOfPred))->opc;
2410 #if defined(YAPOR) || defined(THREADS)
2411 }
2412 #endif
2413 }
2414 } else if (mode == asserta) {
2415 asserta_stat_clause(pe, cp, FALSE);
2416 } else {
2417 assertz_stat_clause(pe, cp, FALSE);
2418 }
2419 }
2420
2421 #if EMACS
2422
2423 /*
2424 * the place where one would add a new clause for the propriety pred_prop
2425 */
2426 int
where_new_clause(pred_prop,mode)2427 where_new_clause(pred_prop, mode)
2428 Prop pred_prop;
2429 int mode;
2430 {
2431 PredEntry *p = RepPredProp(pred_prop);
2432
2433 if (mode == consult && not_was_reconsulted(p, TermNil, FALSE))
2434 return (1);
2435 else
2436 return (p->cs.p_code.NOfClauses + 1);
2437 }
2438 #endif
2439
2440 static Int
p_compile(void)2441 p_compile(void)
2442 { /* '$compile'(+C,+Flags, Mod) */
2443 Term t = Deref(ARG1);
2444 Term t1 = Deref(ARG2);
2445 Term mod = Deref(ARG4);
2446 Term tn = TermNil;
2447 yamop *codeadr;
2448
2449 if (IsVarTerm(t1) || !IsIntTerm(t1))
2450 return (FALSE);
2451 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2452 return (FALSE);
2453
2454 YAPEnterCriticalSection();
2455 codeadr = Yap_cclause(t, 4, mod, Deref(ARG3)); /* vsc: give the number of arguments
2456 to cclause in case there is overflow */
2457 t = Deref(ARG1); /* just in case there was an heap overflow */
2458 if (!Yap_ErrorMessage)
2459 addclause(t, codeadr, (int) (IntOfTerm(t1) & 3), mod, &tn);
2460 YAPLeaveCriticalSection();
2461 if (Yap_ErrorMessage) {
2462 if (IntOfTerm(t1) & 4) {
2463 Yap_Error(Yap_Error_TYPE, Yap_Error_Term,
2464 "in line %d, %s", Yap_FirstLineInParse(), Yap_ErrorMessage);
2465 } else {
2466 Yap_Error(Yap_Error_TYPE, Yap_Error_Term, Yap_ErrorMessage);
2467 }
2468 return FALSE;
2469 }
2470 return TRUE;
2471 }
2472
2473 static Int
p_compile_dynamic(void)2474 p_compile_dynamic(void)
2475 { /* '$compile_dynamic'(+C,+Flags,Mod,-Ref) */
2476 Term t = Deref(ARG1);
2477 Term t1 = Deref(ARG2);
2478 Term mod = Deref(ARG4);
2479 yamop *code_adr;
2480 int old_optimize, mode;
2481
2482 if (IsVarTerm(t1) || !IsAtomicTerm(t1))
2483 return FALSE;
2484 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2485 return FALSE;
2486 if (IsAtomTerm(t1)) {
2487 if (RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f') mode = asserta;
2488 else mode = assertz;
2489 } else mode = IntegerOfTerm(t1);
2490 /* major change to semantics, don't do it...
2491 if (mode == assertz && consult_level)
2492 mode = consult;
2493 */
2494 old_optimize = optimizer_on;
2495 optimizer_on = FALSE;
2496 YAPEnterCriticalSection();
2497 code_adr = Yap_cclause(t, 5, mod, Deref(ARG3)); /* vsc: give the number of arguments to
2498 cclause() in case there is a overflow */
2499 t = Deref(ARG1); /* just in case there was an heap overflow */
2500 if (!Yap_ErrorMessage) {
2501
2502
2503 optimizer_on = old_optimize;
2504 addclause(t, code_adr, mode , mod, &ARG5);
2505 }
2506 if (Yap_ErrorMessage) {
2507 if (!Yap_Error_Term)
2508 Yap_Error_Term = TermNil;
2509 Yap_Error(Yap_Error_TYPE, Yap_Error_Term, Yap_ErrorMessage);
2510 YAPLeaveCriticalSection();
2511 return FALSE;
2512 }
2513 YAPLeaveCriticalSection();
2514 return TRUE;
2515 }
2516
2517 static Atom
YapConsultingFile(void)2518 YapConsultingFile (void)
2519 {
2520 if (consult_level == 0) {
2521 return(AtomUser);
2522 } else {
2523 return(Yap_LookupAtom(ConsultBase[2].filename));
2524 }
2525 }
2526
2527 Atom
Yap_ConsultingFile(void)2528 Yap_ConsultingFile (void)
2529 {
2530 return YapConsultingFile();
2531 }
2532
2533 /* consult file *file*, *mode* may be one of either consult or reconsult */
2534 static void
init_consult(int mode,char * file)2535 init_consult(int mode, char *file)
2536 {
2537 if (!ConsultSp) {
2538 InitConsultStack();
2539 }
2540 ConsultSp--;
2541 ConsultSp->filename = file;
2542 ConsultSp--;
2543 ConsultSp->mode = mode;
2544 ConsultSp--;
2545 ConsultSp->c = (ConsultBase-ConsultSp);
2546 ConsultBase = ConsultSp;
2547 #if !defined(YAPOR) && !defined(SBA)
2548 /* if (consult_level == 0)
2549 do_toggle_static_predicates_in_use(TRUE); */
2550 #endif
2551 consult_level++;
2552 LastAssertedPred = NULL;
2553 }
2554
2555 void
Yap_init_consult(int mode,char * file)2556 Yap_init_consult(int mode, char *file)
2557 {
2558 init_consult(mode,file);
2559 }
2560
2561 static Int
p_startconsult(void)2562 p_startconsult(void)
2563 { /* '$start_consult'(+Mode) */
2564 Term t;
2565 char *smode = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
2566 int mode;
2567
2568 mode = strcmp("consult",smode);
2569 init_consult(mode, RepAtom(AtomOfTerm(Deref(ARG2)))->StrOfAE);
2570 t = MkIntTerm(consult_level);
2571 return (Yap_unify_constant(ARG3, t));
2572 }
2573
2574 static Int
p_showconslultlev(void)2575 p_showconslultlev(void)
2576 {
2577 Term t;
2578
2579 t = MkIntTerm(consult_level);
2580 return (Yap_unify_constant(ARG1, t));
2581 }
2582
2583 static void
end_consult(void)2584 end_consult(void)
2585 {
2586 ConsultSp = ConsultBase;
2587 ConsultBase = ConsultSp+ConsultSp->c;
2588 ConsultSp += 3;
2589 consult_level--;
2590 LastAssertedPred = NULL;
2591 #if !defined(YAPOR) && !defined(SBA)
2592 /* if (consult_level == 0)
2593 do_toggle_static_predicates_in_use(FALSE);*/
2594 #endif
2595 }
2596
2597 void
Yap_end_consult(void)2598 Yap_end_consult(void) {
2599 end_consult();
2600 }
2601
2602
2603 static Int
p_endconsult(void)2604 p_endconsult(void)
2605 { /* '$end_consult' */
2606 end_consult();
2607 return (TRUE);
2608 }
2609
2610 static void
purge_clauses(PredEntry * pred)2611 purge_clauses(PredEntry *pred)
2612 {
2613 if (pred->cs.p_code.NOfClauses) {
2614 if (pred->PredFlags & IndexedPredFlag)
2615 RemoveIndexation(pred);
2616 Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
2617 retract_all(pred, static_in_use(pred,TRUE));
2618 }
2619 pred->src.OwnerFile = AtomNil;
2620 if (pred->PredFlags & MultiFileFlag)
2621 pred->PredFlags ^= MultiFileFlag;
2622 }
2623
2624 void
Yap_Abolish(PredEntry * pred)2625 Yap_Abolish(PredEntry *pred)
2626 {
2627 purge_clauses(pred);
2628 }
2629
2630 static Int
p_purge_clauses(void)2631 p_purge_clauses(void)
2632 { /* '$purge_clauses'(+Func) */
2633 PredEntry *pred;
2634 Term t = Deref(ARG1);
2635 Term mod = Deref(ARG2);
2636
2637 Yap_PutValue(AtomAbol, MkAtomTerm(AtomNil));
2638 if (IsVarTerm(t))
2639 return FALSE;
2640 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
2641 return FALSE;
2642 }
2643 if (IsAtomTerm(t)) {
2644 Atom at = AtomOfTerm(t);
2645 pred = RepPredProp(PredPropByAtom(at, mod));
2646 } else if (IsApplTerm(t)) {
2647 Functor fun = FunctorOfTerm(t);
2648 pred = RepPredProp(PredPropByFunc(fun, mod));
2649 } else
2650 return (FALSE);
2651 PELOCK(21,pred);
2652 if (pred->PredFlags & StandardPredFlag) {
2653 UNLOCKPE(33,pred);
2654 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, t, "assert/1");
2655 return (FALSE);
2656 }
2657 purge_clauses(pred);
2658 UNLOCKPE(34,pred);
2659 return (TRUE);
2660 }
2661
2662 /******************************************************************
2663
2664 MANAGING SPY-POINTS
2665
2666 ******************************************************************/
2667
2668 static Int
p_setspy(void)2669 p_setspy(void)
2670 { /* '$set_spy'(+Fun,+M) */
2671 Atom at;
2672 PredEntry *pred;
2673 CELL fg;
2674 Term t, mod;
2675
2676 at = AtomSpy;
2677 pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
2678 SpyCode = pred;
2679 t = Deref(ARG1);
2680 mod = Deref(ARG2);
2681 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2682 return (FALSE);
2683 if (IsVarTerm(t))
2684 return (FALSE);
2685 if (IsAtomTerm(t)) {
2686 Atom at = AtomOfTerm(t);
2687 pred = RepPredProp(Yap_PredPropByAtomNonThreadLocal(at, mod));
2688 } else if (IsApplTerm(t)) {
2689 Functor fun = FunctorOfTerm(t);
2690 pred = RepPredProp(Yap_PredPropByFunctorNonThreadLocal(fun, mod));
2691 } else {
2692 return (FALSE);
2693 }
2694 PELOCK(22,pred);
2695 restart_spy:
2696 if (pred->PredFlags & (CPredFlag | SafePredFlag)) {
2697 UNLOCKPE(35,pred);
2698 return FALSE;
2699 }
2700 if (pred->OpcodeOfPred == UNDEF_OPCODE ||
2701 pred->OpcodeOfPred == FAIL_OPCODE) {
2702 UNLOCKPE(36,pred);
2703 return FALSE;
2704 }
2705 if (pred->OpcodeOfPred == INDEX_OPCODE) {
2706 int i = 0;
2707 for (i = 0; i < pred->ArityOfPE; i++) {
2708 XREGS[i+1] = MkVarTerm();
2709 }
2710 IPred(pred, 0, CP);
2711 goto restart_spy;
2712 }
2713 fg = pred->PredFlags;
2714 if (fg & DynamicPredFlag) {
2715 pred->OpcodeOfPred =
2716 ((yamop *)(pred->CodeOfPred))->opc =
2717 Yap_opcode(_spy_or_trymark);
2718 } else {
2719 pred->OpcodeOfPred = Yap_opcode(_spy_pred);
2720 pred->CodeOfPred = (yamop *)(&(pred->OpcodeOfPred));
2721 }
2722 pred->PredFlags |= SpiedPredFlag;
2723 UNLOCKPE(37,pred);
2724 return TRUE;
2725 }
2726
2727 static Int
p_rmspy(void)2728 p_rmspy(void)
2729 { /* '$rm_spy'(+T,+Mod) */
2730 Atom at;
2731 PredEntry *pred;
2732 Term t;
2733 Term mod;
2734
2735 t = Deref(ARG1);
2736 mod = Deref(ARG2);
2737 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2738 return (FALSE);
2739 if (IsVarTerm(t))
2740 return (FALSE);
2741 if (IsAtomTerm(t)) {
2742 at = AtomOfTerm(t);
2743 pred = RepPredProp(Yap_PredPropByAtomNonThreadLocal(at, mod));
2744 } else if (IsApplTerm(t)) {
2745 Functor fun = FunctorOfTerm(t);
2746 pred = RepPredProp(Yap_PredPropByFunctorNonThreadLocal(fun, mod));
2747 } else
2748 return FALSE;
2749 PELOCK(23,pred);
2750 if (!(pred->PredFlags & SpiedPredFlag)) {
2751 UNLOCKPE(38,pred);
2752 return FALSE;
2753 }
2754 #if THREADS
2755 if (!(pred->PredFlags & ThreadLocalPredFlag)) {
2756 pred->OpcodeOfPred = Yap_opcode(_thread_local);
2757 pred->PredFlags ^= SpiedPredFlag;
2758 UNLOCKPE(39,pred);
2759 return TRUE;
2760 }
2761 #endif
2762 if (!(pred->PredFlags & (CountPredFlag|ProfiledPredFlag))) {
2763 if (!(pred->PredFlags & DynamicPredFlag)) {
2764 #if defined(YAPOR) || defined(THREADS)
2765 if (pred->PredFlags & LogUpdatePredFlag &&
2766 pred->ModuleOfPred != IDB_MODULE) {
2767 pred->OpcodeOfPred = LOCKPRED_OPCODE;
2768 pred->CodeOfPred = (yamop *)(&(pred->OpcodeOfPred));
2769 } else {
2770 #endif
2771 pred->CodeOfPred = pred->cs.p_code.TrueCodeOfPred;
2772 pred->OpcodeOfPred = pred->CodeOfPred->opc;
2773 #if defined(YAPOR) || defined(THREADS)
2774 }
2775 #endif
2776 } else if (pred->OpcodeOfPred == Yap_opcode(_spy_or_trymark)) {
2777 pred->OpcodeOfPred = Yap_opcode(_try_and_mark);
2778 } else {
2779 UNLOCKPE(39,pred);
2780 return FALSE;
2781 }
2782 }
2783 pred->PredFlags ^= SpiedPredFlag;
2784 UNLOCKPE(40,pred);
2785 return (TRUE);
2786 }
2787
2788
2789 /******************************************************************
2790
2791 INFO ABOUT PREDICATES
2792
2793 ******************************************************************/
2794
2795 static Int
p_number_of_clauses(void)2796 p_number_of_clauses(void)
2797 { /* '$number_of_clauses'(Predicate,M,N) */
2798 Term t = Deref(ARG1);
2799 Term mod = Deref(ARG2);
2800 int ncl = 0;
2801 Prop pe;
2802
2803 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
2804 return(FALSE);
2805 }
2806 if (IsAtomTerm(t)) {
2807 Atom a = AtomOfTerm(t);
2808 pe = Yap_GetPredPropByAtom(a, mod);
2809 } else if (IsApplTerm(t)) {
2810 register Functor f = FunctorOfTerm(t);
2811 pe = Yap_GetPredPropByFunc(f, mod);
2812 } else {
2813 return (FALSE);
2814 }
2815 if (EndOfPAEntr(pe))
2816 return FALSE;
2817 PELOCK(24,RepPredProp(pe));
2818 ncl = RepPredProp(pe)->cs.p_code.NOfClauses;
2819 UNLOCKPE(41,RepPredProp(pe));
2820 return (Yap_unify_constant(ARG3, MkIntegerTerm(ncl)));
2821 }
2822
2823 static Int
p_in_use(void)2824 p_in_use(void)
2825 { /* '$in_use'(+P,+Mod) */
2826 PredEntry *pe;
2827 Int out;
2828
2829 pe = get_pred(Deref(ARG1), Deref(ARG2), "$in_use");
2830 if (EndOfPAEntr(pe))
2831 return FALSE;
2832 PELOCK(25,pe);
2833 out = static_in_use(pe,TRUE);
2834 UNLOCKPE(42,pe);
2835 return(out);
2836 }
2837
2838 static Int
p_new_multifile(void)2839 p_new_multifile(void)
2840 { /* '$new_multifile'(+N,+Ar,+Mod) */
2841 Atom at;
2842 int arity;
2843 PredEntry *pe;
2844 Term t = Deref(ARG1);
2845 Term mod = Deref(ARG3);
2846
2847 if (IsVarTerm(t))
2848 return (FALSE);
2849 if (IsAtomTerm(t))
2850 at = AtomOfTerm(t);
2851 else
2852 return (FALSE);
2853 t = Deref(ARG2);
2854 if (IsVarTerm(t))
2855 return (FALSE);
2856 if (IsIntTerm(t))
2857 arity = IntOfTerm(t);
2858 else
2859 return FALSE;
2860 if (arity == 0)
2861 pe = RepPredProp(PredPropByAtom(at, mod));
2862 else
2863 pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod));
2864 PELOCK(26,pe);
2865 pe->PredFlags |= MultiFileFlag;
2866 if (pe->ModuleOfPred == PROLOG_MODULE)
2867 pe->ModuleOfPred = TermProlog;
2868 if (!(pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
2869 /* static */
2870 pe->PredFlags |= (SourcePredFlag|CompiledPredFlag);
2871 }
2872 UNLOCKPE(43,pe);
2873 return (TRUE);
2874 }
2875
2876
2877 static Int
p_is_multifile(void)2878 p_is_multifile(void)
2879 { /* '$is_multifile'(+S,+Mod) */
2880 PredEntry *pe;
2881 Int out;
2882
2883 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_multifile");
2884 if (EndOfPAEntr(pe))
2885 return FALSE;
2886 PELOCK(27,pe);
2887 out = (pe->PredFlags & MultiFileFlag);
2888 UNLOCKPE(44,pe);
2889 return(out);
2890 }
2891
2892 static Int
p_is_log_updatable(void)2893 p_is_log_updatable(void)
2894 { /* '$is_dynamic'(+P) */
2895 PredEntry *pe;
2896 Int out;
2897
2898 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_log_updatable");
2899 if (EndOfPAEntr(pe))
2900 return FALSE;
2901 PELOCK(27,pe);
2902 out = (pe->PredFlags & LogUpdatePredFlag);
2903 UNLOCKPE(45,pe);
2904 return(out);
2905 }
2906
2907 static Int
p_is_source(void)2908 p_is_source(void)
2909 { /* '$is_dynamic'(+P) */
2910 PredEntry *pe;
2911 Int out;
2912
2913 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2914 if (EndOfPAEntr(pe))
2915 return FALSE;
2916 PELOCK(28,pe);
2917 out = (pe->PredFlags & SourcePredFlag);
2918 UNLOCKPE(46,pe);
2919 return(out);
2920 }
2921
2922 static Int
p_owner_file(void)2923 p_owner_file(void)
2924 { /* '$owner_file'(+P,M,F) */
2925 PredEntry *pe;
2926 Atom owner;
2927
2928 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2929 if (EndOfPAEntr(pe))
2930 return FALSE;
2931 PELOCK(29,pe);
2932 if (pe->ModuleOfPred == IDB_MODULE) {
2933 UNLOCKPE(47,pe);
2934 return FALSE;
2935 }
2936 if (pe->PredFlags & MultiFileFlag) {
2937 UNLOCKPE(48,pe);
2938 return FALSE;
2939 }
2940 owner = pe->src.OwnerFile;
2941 UNLOCKPE(49,pe);
2942 return Yap_unify(ARG3, MkAtomTerm(owner));
2943 }
2944
2945 static Int
p_mk_d(void)2946 p_mk_d(void)
2947 { /* '$is_dynamic'(+P) */
2948 PredEntry *pe;
2949
2950 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2951 if (EndOfPAEntr(pe))
2952 return FALSE;
2953 PELOCK(30,pe);
2954 if (pe->OpcodeOfPred == UNDEF_OPCODE) {
2955 pe->OpcodeOfPred = FAIL_OPCODE;
2956 }
2957 UNLOCKPE(50,pe);
2958 return TRUE;
2959 }
2960
2961 static Int
p_is_dynamic(void)2962 p_is_dynamic(void)
2963 { /* '$is_dynamic'(+P) */
2964 PredEntry *pe;
2965 Int out;
2966
2967 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_dynamic");
2968 if (EndOfPAEntr(pe))
2969 return FALSE;
2970 PELOCK(31,pe);
2971 out = (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag));
2972 UNLOCKPE(51,pe);
2973 return(out);
2974 }
2975
2976 static Int
p_is_metapredicate(void)2977 p_is_metapredicate(void)
2978 { /* '$is_metapredicate'(+P) */
2979 PredEntry *pe;
2980 Int out;
2981
2982 pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_meta");
2983 if (EndOfPAEntr(pe))
2984 return FALSE;
2985 PELOCK(32,pe);
2986 out = (pe->PredFlags & MetaPredFlag);
2987 UNLOCKPE(52,pe);
2988 return out;
2989 }
2990
2991 static Int
p_is_expandgoalormetapredicate(void)2992 p_is_expandgoalormetapredicate(void)
2993 { /* '$is_expand_goal_predicate'(+P) */
2994 PredEntry *pe;
2995 Term t = Deref(ARG1);
2996 Term mod = Deref(ARG2);
2997 Int out;
2998
2999 if (PRED_GOAL_EXPANSION_ALL)
3000 return TRUE;
3001 if (IsVarTerm(t)) {
3002 return (FALSE);
3003 } else if (IsAtomTerm(t)) {
3004 Atom at = AtomOfTerm(t);
3005 pe = RepPredProp(Yap_GetPredPropByAtom(at, mod));
3006 if (EndOfPAEntr(pe)) {
3007 if (PRED_GOAL_EXPANSION_FUNC) {
3008 Prop p1 = RepAtom(at)->PropsOfAE;
3009
3010 while (p1) {
3011 PredEntry *pe = RepPredProp(p1);
3012
3013 if (pe->KindOfPE == PEProp) {
3014 if (pe->PredFlags & GoalExPredFlag) {
3015 PredPropByAtom(at, mod);
3016 return TRUE;
3017 } else {
3018 return FALSE;
3019 }
3020 }
3021 p1 = pe->NextOfPE;
3022 }
3023 }
3024 return FALSE;
3025 }
3026 } else if (IsApplTerm(t)) {
3027 Functor fun = FunctorOfTerm(t);
3028
3029 if (IsExtensionFunctor(fun)) {
3030 return FALSE;
3031 }
3032 pe = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
3033 if (EndOfPAEntr(pe)) {
3034 if (PRED_GOAL_EXPANSION_FUNC) {
3035 FunctorEntry *fe = (FunctorEntry *)fun;
3036 if (fe->PropsOfFE &&
3037 (RepPredProp(fe->PropsOfFE)->PredFlags & GoalExPredFlag)) {
3038 PredPropByFunc(fun, mod);
3039 return TRUE;
3040 }
3041 }
3042 return FALSE;
3043 }
3044 } else {
3045 return FALSE;
3046 }
3047
3048 PELOCK(33,pe);
3049 out = (pe->PredFlags & (GoalExPredFlag|MetaPredFlag));
3050 UNLOCKPE(53,pe);
3051 return(out);
3052 }
3053
3054 static Int
p_pred_exists(void)3055 p_pred_exists(void)
3056 { /* '$pred_exists'(+P,+M) */
3057 PredEntry *pe;
3058 Int out;
3059
3060 pe = get_pred(Deref(ARG1), Deref(ARG2), "$exists");
3061 if (EndOfPAEntr(pe))
3062 return FALSE;
3063 PELOCK(34,pe);
3064 if (pe->PredFlags & HiddenPredFlag){
3065 UNLOCKPE(54,pe);
3066 return FALSE;
3067 }
3068 out = (pe->OpcodeOfPred != UNDEF_OPCODE);
3069 UNLOCKPE(55,pe);
3070 return out;
3071 }
3072
3073 static Int
p_set_pred_module(void)3074 p_set_pred_module(void)
3075 { /* '$set_pred_module'(+P,+Mod) */
3076 PredEntry *pe;
3077
3078 pe = get_pred(Deref(ARG1), CurrentModule, "set_pred_module/1");
3079 if (EndOfPAEntr(pe))
3080 return FALSE;
3081 PELOCK(35,pe);
3082 pe->ModuleOfPred = Deref(ARG2);
3083 UNLOCKPE(56,pe);
3084 return(TRUE);
3085 }
3086
3087 static Int
p_undefined(void)3088 p_undefined(void)
3089 { /* '$undefined'(P,Mod) */
3090 PredEntry *pe;
3091
3092 pe = get_pred(Deref(ARG1), Deref(ARG2), "undefined/1");
3093 if (EndOfPAEntr(pe))
3094 return TRUE;
3095 PELOCK(36,pe);
3096 if (pe->PredFlags & (CPredFlag|UserCPredFlag|TestPredFlag|AsmPredFlag|DynamicPredFlag|LogUpdatePredFlag)) {
3097 UNLOCKPE(57,pe);
3098 return FALSE;
3099 }
3100 if (pe->OpcodeOfPred == UNDEF_OPCODE) {
3101 UNLOCKPE(58,pe);
3102 return TRUE;
3103 }
3104 UNLOCKPE(59,pe);
3105 return FALSE;
3106 }
3107
3108 /*
3109 * this predicate should only be called when all clauses for the dynamic
3110 * predicate were remove, otherwise chaos will follow!!
3111 */
3112
3113 static Int
p_kill_dynamic(void)3114 p_kill_dynamic(void)
3115 { /* '$kill_dynamic'(P,M) */
3116 PredEntry *pe;
3117
3118 pe = get_pred(Deref(ARG1), Deref(ARG2), "kill_dynamic/1");
3119 if (EndOfPAEntr(pe))
3120 return TRUE;
3121 PELOCK(37,pe);
3122 if (!(pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
3123 UNLOCKPE(60,pe);
3124 return FALSE;
3125 }
3126 if (pe->cs.p_code.LastClause != pe->cs.p_code.FirstClause) {
3127 UNLOCKPE(61,pe);
3128 return (FALSE);
3129 }
3130 pe->cs.p_code.LastClause = pe->cs.p_code.FirstClause = NULL;
3131 pe->OpcodeOfPred = UNDEF_OPCODE;
3132 pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
3133 pe->PredFlags = pe->PredFlags & GoalExPredFlag;
3134 UNLOCKPE(62,pe);
3135 return (TRUE);
3136 }
3137
3138 static Int
p_optimizer_on(void)3139 p_optimizer_on(void)
3140 { /* '$optimizer_on' */
3141 optimizer_on = TRUE;
3142 return (TRUE);
3143 }
3144
3145 static Int
p_optimizer_off(void)3146 p_optimizer_off(void)
3147 { /* '$optimizer_off' */
3148 optimizer_on = FALSE;
3149 return (TRUE);
3150 }
3151
3152 static Int
p_compile_mode(void)3153 p_compile_mode(void)
3154 { /* $compile_mode(Old,New) */
3155 Term t2, t3 = MkIntTerm(compile_mode);
3156 if (!Yap_unify_constant(ARG1, t3))
3157 return (FALSE);
3158 t2 = Deref(ARG2);
3159 if (IsVarTerm(t2) || !IsIntTerm(t2))
3160 return (FALSE);
3161 compile_mode = IntOfTerm(t2) & 1;
3162 return (TRUE);
3163 }
3164
3165 #if !defined(YAPOR) && !defined(THREADS)
cur_clause(PredEntry * pe,yamop * codeptr)3166 static yamop *cur_clause(PredEntry *pe, yamop *codeptr)
3167 {
3168 StaticClause *cl;
3169
3170 cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
3171 do {
3172 if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
3173 return cl->ClCode;
3174 }
3175 if (cl->ClCode == pe->cs.p_code.LastClause)
3176 break;
3177 cl = cl->ClNext;
3178 } while (TRUE);
3179 Yap_Error(SYSTEM_ERROR,TermNil,"could not find clause for indexing code");
3180 return(NULL);
3181 }
3182
cur_log_upd_clause(PredEntry * pe,yamop * codeptr)3183 static yamop *cur_log_upd_clause(PredEntry *pe, yamop *codeptr)
3184 {
3185 LogUpdClause *cl;
3186 cl = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
3187 do {
3188 if (IN_BLOCK(codeptr,cl->ClCode,cl->ClSize)) {
3189 return((yamop *)cl->ClCode);
3190 }
3191 cl = cl->ClNext;
3192 } while (cl != NULL);
3193 Yap_Error(SYSTEM_ERROR,TermNil,"could not find clause for indexing code");
3194 return(NULL);
3195 }
3196
3197 static Int
search_for_static_predicate_in_use(PredEntry * p,int check_everything)3198 search_for_static_predicate_in_use(PredEntry *p, int check_everything)
3199 {
3200 choiceptr b_ptr = B;
3201 CELL *env_ptr = ENV;
3202
3203 if (check_everything && P) {
3204 PredEntry *pe = EnvPreg(P);
3205 if (p == pe) return TRUE;
3206 pe = EnvPreg(CP);
3207 if (p == pe) return TRUE;
3208 }
3209 do {
3210 PredEntry *pe;
3211
3212 /* check first environments that are younger than our latest choicepoint */
3213 if (check_everything && env_ptr) {
3214 /*
3215 I do not need to check environments for asserts,
3216 only for retracts
3217 */
3218 while (env_ptr && b_ptr > (choiceptr)env_ptr) {
3219 yamop *cp = (yamop *)env_ptr[E_CP];
3220 PredEntry *pe;
3221
3222 pe = EnvPreg(cp);
3223 if (p == pe) return(TRUE);
3224 if (env_ptr != NULL)
3225 env_ptr = (CELL *)(env_ptr[E_E]);
3226 }
3227 }
3228 /* now mark the choicepoint */
3229
3230 if (b_ptr)
3231 pe = PredForChoicePt(b_ptr->cp_ap);
3232 else
3233 return FALSE;
3234 if (pe == p) {
3235 if (check_everything)
3236 return TRUE;
3237 PELOCK(38,p);
3238 if (p->PredFlags & IndexedPredFlag) {
3239 yamop *code_p = b_ptr->cp_ap;
3240 yamop *code_beg = p->cs.p_code.TrueCodeOfPred;
3241
3242 /* FIX ME */
3243
3244 if (p->PredFlags & LogUpdatePredFlag) {
3245 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
3246 if (find_owner_log_index(cl, code_p))
3247 b_ptr->cp_ap = cur_log_upd_clause(pe, b_ptr->cp_ap->u.Otapl.d);
3248 } else if (p->PredFlags & MegaClausePredFlag) {
3249 StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
3250 if (find_owner_static_index(cl, code_p))
3251 b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.Otapl.d);
3252 } else {
3253 /* static clause */
3254 StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
3255 if (find_owner_static_index(cl, code_p)) {
3256 b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.Otapl.d);
3257 }
3258 }
3259 }
3260 UNLOCKPE(63,pe);
3261 }
3262 env_ptr = b_ptr->cp_env;
3263 b_ptr = b_ptr->cp_b;
3264 } while (b_ptr != NULL);
3265 return(FALSE);
3266 }
3267
3268 static void
mark_pred(int mark,PredEntry * pe)3269 mark_pred(int mark, PredEntry *pe)
3270 {
3271 /* if the predicate is static mark it */
3272 if (pe->ModuleOfPred) {
3273 PELOCK(39,p);
3274 if (mark) {
3275 pe->PredFlags |= InUsePredFlag;
3276 } else {
3277 pe->PredFlags &= ~InUsePredFlag;
3278 }
3279 UNLOCK(pe->PELock);
3280 }
3281 }
3282
3283 /* go up the chain of choice_points and environments,
3284 marking all static predicates that current execution is depending
3285 upon */
3286 static void
do_toggle_static_predicates_in_use(int mask)3287 do_toggle_static_predicates_in_use(int mask)
3288 {
3289 choiceptr b_ptr = B;
3290 CELL *env_ptr = ENV;
3291
3292 if (b_ptr == NULL)
3293 return;
3294
3295 do {
3296 PredEntry *pe;
3297 /* check first environments that are younger than our latest choicepoint */
3298 while (b_ptr > (choiceptr)env_ptr) {
3299 PredEntry *pe = EnvPreg((yamop *)env_ptr[E_CP]);
3300
3301 mark_pred(mask, pe);
3302 env_ptr = (CELL *)(env_ptr[E_E]);
3303 }
3304 /* now mark the choicepoint */
3305 if ((b_ptr)) {
3306 if ((pe = PredForChoicePt(b_ptr->cp_ap))) {
3307 mark_pred(mask, pe);
3308 }
3309 }
3310 env_ptr = b_ptr->cp_env;
3311 b_ptr = b_ptr->cp_b;
3312 } while (b_ptr != NULL);
3313 /* mark or unmark all predicates */
3314 STATIC_PREDICATES_MARKED = mask;
3315 }
3316
3317 #endif /* !defined(YAPOR) && !defined(THREADS) */
3318
3319 static LogUpdIndex *
find_owner_log_index(LogUpdIndex * cl,yamop * code_p)3320 find_owner_log_index(LogUpdIndex *cl, yamop *code_p)
3321 {
3322 yamop *code_beg = cl->ClCode;
3323 yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
3324
3325 if (code_p >= code_beg && code_p <= code_end) {
3326 return cl;
3327 }
3328 cl = cl->ChildIndex;
3329 while (cl != NULL) {
3330 LogUpdIndex *out;
3331 if ((out = find_owner_log_index(cl, code_p)) != NULL) {
3332 return out;
3333 }
3334 cl = cl->SiblingIndex;
3335 }
3336 return NULL;
3337 }
3338
3339 static StaticIndex *
find_owner_static_index(StaticIndex * cl,yamop * code_p)3340 find_owner_static_index(StaticIndex *cl, yamop *code_p)
3341 {
3342 yamop *code_beg = cl->ClCode;
3343 yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
3344
3345 if (code_p >= code_beg && code_p <= code_end) {
3346 return cl;
3347 }
3348 cl = cl->ChildIndex;
3349 while (cl != NULL) {
3350 StaticIndex *out;
3351 if ((out = find_owner_static_index(cl, code_p)) != NULL) {
3352 return out;
3353 }
3354 cl = cl->SiblingIndex;
3355 }
3356 return NULL;
3357 }
3358
3359 ClauseUnion *
Yap_find_owner_index(yamop * ipc,PredEntry * ap)3360 Yap_find_owner_index(yamop *ipc, PredEntry *ap)
3361 {
3362 /* we assume we have an owner index */
3363 if (ap->PredFlags & LogUpdatePredFlag) {
3364 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred);
3365 return (ClauseUnion *)find_owner_log_index(cl,ipc);
3366 } else {
3367 StaticIndex *cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
3368 return (ClauseUnion *)find_owner_static_index(cl,ipc);
3369 }
3370 }
3371
3372 static Term
all_envs(CELL * env_ptr)3373 all_envs(CELL *env_ptr)
3374 {
3375 Term tf = AbsPair(H);
3376 CELL *start = H;
3377 CELL *bp = NULL;
3378
3379 /* walk the environment chain */
3380 while (env_ptr) {
3381 bp = H;
3382 H += 2;
3383 /* notice that MkIntegerTerm may increase the Heap */
3384 bp[0] = MkIntegerTerm(LCL0-env_ptr);
3385 if (H >= ASP-1024) {
3386 H = start;
3387 Yap_Error_Size = (ASP-1024)-H;
3388 while (env_ptr) {
3389 Yap_Error_Size += 2;
3390 env_ptr = (CELL *)(env_ptr[E_E]);
3391 }
3392 return 0L;
3393 } else {
3394 bp[1] = AbsPair(H);
3395 }
3396 env_ptr = (CELL *)(env_ptr[E_E]);
3397 }
3398 bp[1] = TermNil;
3399 return tf;
3400 }
3401
3402 static Term
all_cps(choiceptr b_ptr)3403 all_cps(choiceptr b_ptr)
3404 {
3405 CELL *bp = NULL;
3406 CELL *start = H;
3407 Term tf = AbsPair(H);
3408
3409 while (b_ptr) {
3410 bp = H;
3411 H += 2;
3412 /* notice that MkIntegerTerm may increase the Heap */
3413 bp[0] = MkIntegerTerm((Int)(LCL0-(CELL *)b_ptr));
3414 if (H >= ASP-1024) {
3415 H = start;
3416 Yap_Error_Size = (ASP-1024)-H;
3417 while (b_ptr) {
3418 Yap_Error_Size += 2;
3419 b_ptr = b_ptr->cp_b;
3420 }
3421 return 0L;
3422 } else {
3423 bp[1] = AbsPair(H);
3424 }
3425 b_ptr = b_ptr->cp_b;
3426 }
3427 bp[1] = TermNil;
3428 return tf;
3429 }
3430
3431
3432 static Term
all_calls(void)3433 all_calls(void)
3434 {
3435 Term ts[4];
3436 Functor f = Yap_MkFunctor(AtomLocalSp,4);
3437
3438 ts[0] = MkIntegerTerm((Int)P);
3439 ts[1] = MkIntegerTerm((Int)CP);
3440 if (yap_flags[STACK_DUMP_ON_ERROR_FLAG]) {
3441 ts[2] = all_envs(ENV);
3442 ts[3] = all_cps(B);
3443 if (ts[2] == 0L ||
3444 ts[3] == 0L)
3445 return 0L;
3446 } else {
3447 ts[2] = ts[3] = TermNil;
3448 }
3449 return Yap_MkApplTerm(f,4,ts);
3450 }
3451
3452 Term
Yap_all_calls(void)3453 Yap_all_calls(void)
3454 {
3455 return all_calls();
3456 }
3457
3458 static Int
p_all_choicepoints(void)3459 p_all_choicepoints(void)
3460 {
3461 Term t;
3462 while ((t = all_cps(B)) == 0L) {
3463 if (!Yap_gcl(Yap_Error_Size, 1, ENV, gc_P(P,CP))) {
3464 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "while dumping choicepoints");
3465 return FALSE;
3466 }
3467 }
3468 return Yap_unify(ARG1,t);
3469 }
3470
3471 static Int
p_all_envs(void)3472 p_all_envs(void)
3473 {
3474 Term t;
3475 while ((t = all_envs(ENV)) == 0L) {
3476 if (!Yap_gcl(Yap_Error_Size, 1, ENV, gc_P(P,CP))) {
3477 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "while dumping environments");
3478 return FALSE;
3479 }
3480 }
3481 return Yap_unify(ARG1,t);
3482 }
3483
3484 static Int
p_current_stack(void)3485 p_current_stack(void)
3486 {
3487 Term t;
3488 while ((t = all_calls()) == 0L) {
3489 if (!Yap_gcl(Yap_Error_Size, 1, ENV, gc_P(P,CP))) {
3490 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "while dumping stack");
3491 return FALSE;
3492 }
3493 }
3494 return Yap_unify(ARG1,t);
3495 }
3496
3497 /* This predicate is to be used by reconsult to mark all predicates
3498 currently in use as being executed.
3499
3500 The idea is to go up the chain of choice_points and environments.
3501
3502 */
3503 static Int
p_toggle_static_predicates_in_use(void)3504 p_toggle_static_predicates_in_use(void)
3505 {
3506 #if !defined(YAPOR) && !defined(THREADS)
3507 Term t = Deref(ARG1);
3508 Int mask;
3509
3510 /* find out whether we need to mark or unmark */
3511 if (IsVarTerm(t)) {
3512 Yap_Error(INSTANTIATION_ERROR,t,"toggle_static_predicates_in_use/1");
3513 return(FALSE);
3514 }
3515 if (!IsIntTerm(t)) {
3516 Yap_Error(TYPE_ERROR_INTEGER,t,"toggle_static_predicates_in_use/1");
3517 return(FALSE);
3518 } else {
3519 mask = IntOfTerm(t);
3520 }
3521 do_toggle_static_predicates_in_use(mask);
3522 #endif
3523 return TRUE;
3524 }
3525
3526 static void
clause_was_found(PredEntry * pp,Atom * pat,UInt * parity)3527 clause_was_found(PredEntry *pp, Atom *pat, UInt *parity) {
3528 if (pp->ModuleOfPred == IDB_MODULE) {
3529 if (pp->PredFlags & NumberDBPredFlag) {
3530 *parity = 0;
3531 *pat = AtomInteger;
3532 } else if (pp->PredFlags & AtomDBPredFlag) {
3533 *parity = 0;
3534 *pat = (Atom)pp->FunctorOfPred;
3535 } else {
3536 *pat = NameOfFunctor(pp->FunctorOfPred);
3537 *parity = ArityOfFunctor(pp->FunctorOfPred);
3538 }
3539 } else {
3540 *parity = pp->ArityOfPE;
3541 if (pp->ArityOfPE) {
3542 *pat = NameOfFunctor(pp->FunctorOfPred);
3543 } else {
3544 *pat = (Atom)(pp->FunctorOfPred);
3545 }
3546 }
3547 }
3548
3549 static void
code_in_pred_info(PredEntry * pp,Atom * pat,UInt * parity)3550 code_in_pred_info(PredEntry *pp, Atom *pat, UInt *parity) {
3551 clause_was_found(pp, pat, parity);
3552 }
3553
3554 static int
code_in_pred_lu_index(LogUpdIndex * icl,yamop * codeptr,CODEADDR * startp,CODEADDR * endp)3555 code_in_pred_lu_index(LogUpdIndex *icl, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
3556 LogUpdIndex *cicl;
3557 if (IN_BLOCK(codeptr,icl,icl->ClSize)) {
3558 if (startp) *startp = (CODEADDR)icl;
3559 if (endp) *endp = (CODEADDR)icl+icl->ClSize;
3560 return TRUE;
3561 }
3562 cicl = icl->ChildIndex;
3563 while (cicl != NULL) {
3564 if (code_in_pred_lu_index(cicl, codeptr, startp, endp))
3565 return TRUE;
3566 cicl = cicl->SiblingIndex;
3567 }
3568 return FALSE;
3569 }
3570
3571 static int
code_in_pred_s_index(StaticIndex * icl,yamop * codeptr,CODEADDR * startp,CODEADDR * endp)3572 code_in_pred_s_index(StaticIndex *icl, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
3573 StaticIndex *cicl;
3574 if (IN_BLOCK(codeptr,icl,icl->ClSize)) {
3575 if (startp) *startp = (CODEADDR)icl;
3576 if (endp) *endp = (CODEADDR)icl+icl->ClSize;
3577 return TRUE;
3578 }
3579 cicl = icl->ChildIndex;
3580 while (cicl != NULL) {
3581 if (code_in_pred_s_index(cicl, codeptr, startp, endp))
3582 return TRUE;
3583 cicl = cicl->SiblingIndex;
3584 }
3585 return FALSE;
3586 }
3587
3588 static Int
find_code_in_clause(PredEntry * pp,yamop * codeptr,CODEADDR * startp,CODEADDR * endp)3589 find_code_in_clause(PredEntry *pp, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
3590 Int i = 1;
3591 yamop *clcode;
3592
3593 clcode = pp->cs.p_code.FirstClause;
3594 if (clcode != NULL) {
3595 if (pp->PredFlags & LogUpdatePredFlag) {
3596 LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
3597 do {
3598 if (IN_BLOCK(codeptr,(CODEADDR)cl,cl->ClSize)) {
3599 if (startp)
3600 *startp = (CODEADDR)cl;
3601 if (endp)
3602 *endp = (CODEADDR)cl+cl->ClSize;
3603 return i;
3604 }
3605 i++;
3606 cl = cl->ClNext;
3607 } while (cl != NULL);
3608 } else if (pp->PredFlags & DynamicPredFlag) {
3609 do {
3610 DynamicClause *cl;
3611
3612 cl = ClauseCodeToDynamicClause(clcode);
3613 if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
3614 if (startp)
3615 *startp = (CODEADDR)cl;
3616 if (endp)
3617 *endp = (CODEADDR)cl+cl->ClSize;
3618 return i;
3619 }
3620 if (clcode == pp->cs.p_code.LastClause)
3621 break;
3622 i++;
3623 clcode = NextDynamicClause(clcode);
3624 } while (TRUE);
3625 } else if (pp->PredFlags & MegaClausePredFlag) {
3626 MegaClause *cl;
3627
3628 cl = ClauseCodeToMegaClause(clcode);
3629 if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
3630 if (startp)
3631 *startp = (CODEADDR)cl;
3632 if (endp)
3633 *endp = (CODEADDR)cl+cl->ClSize;
3634 return 1+((char *)codeptr-(char *)cl->ClCode)/cl->ClItemSize;
3635 }
3636 } else {
3637 StaticClause *cl;
3638
3639 cl = ClauseCodeToStaticClause(clcode);
3640 do {
3641 if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
3642 if (startp)
3643 *startp = (CODEADDR)cl;
3644 if (endp)
3645 *endp = (CODEADDR)cl+cl->ClSize;
3646 return i;
3647 }
3648 if (cl->ClCode == pp->cs.p_code.LastClause)
3649 break;
3650 i++;
3651 cl = cl->ClNext;
3652 } while (TRUE);
3653 }
3654 }
3655 return(0);
3656 }
3657
3658 static int
cl_code_in_pred(PredEntry * pp,yamop * codeptr,CODEADDR * startp,CODEADDR * endp)3659 cl_code_in_pred(PredEntry *pp, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
3660 Int out;
3661
3662 PELOCK(39,pp);
3663 /* check if the codeptr comes from the indexing code */
3664 if (pp->PredFlags & IndexedPredFlag) {
3665 if (pp->PredFlags & LogUpdatePredFlag) {
3666 if (code_in_pred_lu_index(ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, startp, endp)) {
3667 UNLOCK(pp->PELock);
3668 return TRUE;
3669 }
3670 } else {
3671 if (code_in_pred_s_index(ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, startp, endp)) {
3672 UNLOCK(pp->PELock);
3673 return TRUE;
3674 }
3675 }
3676 }
3677 if (pp->PredFlags & (CPredFlag|AsmPredFlag|UserCPredFlag)) {
3678 StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
3679 if (IN_BLOCK(codeptr,(CODEADDR)cl,cl->ClSize)) {
3680 if (startp)
3681 *startp = (CODEADDR)cl;
3682 if (endp)
3683 *endp = (CODEADDR)cl+cl->ClSize;
3684 UNLOCK(pp->PELock);
3685 return TRUE;
3686 } else {
3687 UNLOCK(pp->PELock);
3688 return FALSE;
3689 }
3690 } else {
3691 out = find_code_in_clause(pp, codeptr, startp, endp);
3692 }
3693 UNLOCK(pp->PELock);
3694 if (out) return TRUE;
3695 return FALSE;
3696 }
3697
3698 static Int
code_in_pred(PredEntry * pp,Atom * pat,UInt * parity,yamop * codeptr)3699 code_in_pred(PredEntry *pp, Atom *pat, UInt *parity, yamop *codeptr) {
3700 Int out;
3701
3702 PELOCK(40,pp);
3703 /* check if the codeptr comes from the indexing code */
3704 if (pp->PredFlags & IndexedPredFlag) {
3705 if (pp->PredFlags & LogUpdatePredFlag) {
3706 if (code_in_pred_lu_index(ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, NULL, NULL)) {
3707 code_in_pred_info(pp, pat, parity);
3708 UNLOCK(pp->PELock);
3709 return -1;
3710 }
3711 } else {
3712 if (code_in_pred_s_index(ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, NULL, NULL)) {
3713 code_in_pred_info(pp, pat, parity);
3714 UNLOCK(pp->PELock);
3715 return -1;
3716 }
3717 }
3718 }
3719 if ((out = find_code_in_clause(pp, codeptr, NULL, NULL))) {
3720 clause_was_found(pp, pat, parity);
3721 }
3722 UNLOCK(pp->PELock);
3723 return out;
3724 }
3725
3726 static Int
PredForCode(yamop * codeptr,Atom * pat,UInt * parity,Term * pmodule)3727 PredForCode(yamop *codeptr, Atom *pat, UInt *parity, Term *pmodule) {
3728 Int found = 0;
3729 ModEntry *me = CurrentModules;
3730
3731 /* should we allow the user to see hidden predicates? */
3732 while (me) {
3733
3734 PredEntry *pp;
3735 pp = me->PredForME;
3736 while (pp != NULL) {
3737 if ((found = code_in_pred(pp, pat, parity, codeptr)) != 0) {
3738 *pmodule = MkAtomTerm(me->AtomOfME);
3739 return found;
3740 }
3741 pp = pp->NextPredOfModule;
3742 }
3743 me = me->NextME;
3744 }
3745 return(0);
3746 }
3747
3748 Int
Yap_PredForCode(yamop * codeptr,find_pred_type where_from,Atom * pat,UInt * parity,Term * pmodule)3749 Yap_PredForCode(yamop *codeptr, find_pred_type where_from, Atom *pat, UInt *parity, Term *pmodule) {
3750 PredEntry *p;
3751
3752 if (where_from == FIND_PRED_FROM_CP) {
3753 p = PredForChoicePt(codeptr);
3754 } else if (where_from == FIND_PRED_FROM_ENV) {
3755 p = EnvPreg(codeptr);
3756 if (p) {
3757 Int out;
3758 if (p->ModuleOfPred == PROLOG_MODULE)
3759 *pmodule = TermProlog;
3760 else
3761 *pmodule = p->ModuleOfPred;
3762 out = find_code_in_clause(p, codeptr, NULL, NULL);
3763 clause_was_found(p, pat, parity);
3764 return out;
3765 }
3766 } else {
3767 return PredForCode(codeptr, pat, parity, pmodule);
3768 }
3769 if (p == NULL) {
3770 return 0;
3771 }
3772 clause_was_found(p, pat, parity);
3773 if (p->ModuleOfPred == PROLOG_MODULE)
3774 *pmodule = TermProlog;
3775 else
3776 *pmodule = p->ModuleOfPred;
3777 return -1;
3778 }
3779
3780 /* intruction blocks we found ourselves at */
3781 static PredEntry *
walk_got_lu_block(LogUpdIndex * cl,CODEADDR * startp,CODEADDR * endp)3782 walk_got_lu_block(LogUpdIndex *cl, CODEADDR *startp, CODEADDR *endp)
3783 {
3784 PredEntry *pp = cl->ClPred;
3785 *startp = (CODEADDR)cl;
3786 *endp = (CODEADDR)cl+cl->ClSize;
3787 return pp;
3788 }
3789
3790 /* intruction blocks we found ourselves at */
3791 static PredEntry *
walk_got_lu_clause(LogUpdClause * cl,CODEADDR * startp,CODEADDR * endp)3792 walk_got_lu_clause(LogUpdClause *cl, CODEADDR *startp, CODEADDR *endp)
3793 {
3794 *startp = (CODEADDR)cl;
3795 *endp = (CODEADDR)cl+cl->ClSize;
3796 return cl->ClPred;
3797 }
3798
3799 /* we hit a meta-call, so we don't know what is happening */
3800 static PredEntry *
found_meta_call(CODEADDR * startp,CODEADDR * endp)3801 found_meta_call(CODEADDR *startp, CODEADDR *endp)
3802 {
3803 PredEntry *pp = PredMetaCall;
3804 *startp = (CODEADDR)&(pp->OpcodeOfPred);
3805 *endp = (CODEADDR)NEXTOP((yamop *)&(pp->OpcodeOfPred),e);
3806 return pp;
3807 }
3808
3809 /* intruction blocks we found ourselves at */
3810 static PredEntry *
walk_found_c_pred(PredEntry * pp,CODEADDR * startp,CODEADDR * endp)3811 walk_found_c_pred(PredEntry *pp, CODEADDR *startp, CODEADDR *endp)
3812 {
3813 StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
3814 *startp = (CODEADDR)&(cl->ClCode);
3815 *endp = (CODEADDR)&(cl->ClCode)+cl->ClSize;
3816 return pp;
3817 }
3818
3819 /* we hit a mega-clause, no point in going on */
3820 static PredEntry *
found_mega_clause(PredEntry * pp,CODEADDR * startp,CODEADDR * endp)3821 found_mega_clause(PredEntry *pp, CODEADDR *startp, CODEADDR *endp)
3822 {
3823 MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
3824 *startp = (CODEADDR)mcl;
3825 *endp = (CODEADDR)mcl+mcl->ClSize;
3826 return pp;
3827 }
3828
3829 /* we hit a mega-clause, no point in going on */
3830 static PredEntry *
found_idb_clause(yamop * pc,CODEADDR * startp,CODEADDR * endp)3831 found_idb_clause(yamop *pc, CODEADDR *startp, CODEADDR *endp)
3832 {
3833 LogUpdClause *cl = ClauseCodeToLogUpdClause(pc);
3834
3835 *startp = (CODEADDR)cl;
3836 *endp = (CODEADDR)cl+cl->ClSize;
3837 return cl->ClPred;
3838 }
3839
3840 /* we hit a expand_index, no point in going on */
3841 static PredEntry *
found_expand_index(yamop * pc,CODEADDR * startp,CODEADDR * endp,yamop * codeptr)3842 found_expand_index(yamop *pc, CODEADDR *startp, CODEADDR *endp, yamop *codeptr)
3843 {
3844 PredEntry *pp = codeptr->u.sssllp.p;
3845 if (pc == codeptr) {
3846 *startp = (CODEADDR)codeptr;
3847 *endp = (CODEADDR)NEXTOP(codeptr,sssllp);
3848 }
3849 return pp;
3850 }
3851
3852 /* we hit a expand_index, no point in going on */
3853 static PredEntry *
found_fail(yamop * pc,CODEADDR * startp,CODEADDR * endp)3854 found_fail(yamop *pc, CODEADDR *startp, CODEADDR *endp)
3855 {
3856 PredEntry *pp = RepPredProp(Yap_GetPredPropByAtom(AtomFail,CurrentModule));
3857 *startp = *endp = (CODEADDR)FAILCODE;
3858 return pp;
3859 }
3860
3861 /* we hit a expand_index, no point in going on */
3862 static PredEntry *
found_owner_op(yamop * pc,CODEADDR * startp,CODEADDR * endp)3863 found_owner_op(yamop *pc, CODEADDR *startp, CODEADDR *endp)
3864 {
3865 PredEntry *pp = ((PredEntry *)(Unsigned(pc)-(CELL)(&(((PredEntry *)NULL)->OpcodeOfPred))));
3866 *startp = (CODEADDR)&(pp->OpcodeOfPred);
3867 *endp = (CODEADDR)NEXTOP((yamop *)&(pp->OpcodeOfPred),e);
3868 return pp;
3869 }
3870
3871 /* we hit a expand_index, no point in going on */
3872 static PredEntry *
found_expand(yamop * pc,CODEADDR * startp,CODEADDR * endp)3873 found_expand(yamop *pc, CODEADDR *startp, CODEADDR *endp)
3874 {
3875 PredEntry *pp = ((PredEntry *)(Unsigned(pc)-(CELL)(&(((PredEntry *)NULL)->cs.p_code.ExpandCode))));
3876 *startp = (CODEADDR)&(pp->cs.p_code.ExpandCode);
3877 *endp = (CODEADDR)NEXTOP((yamop *)&(pp->cs.p_code.ExpandCode),e);
3878 return pp;
3879 }
3880
3881 static PredEntry *
found_ystop(yamop * pc,int clause_code,CODEADDR * startp,CODEADDR * endp,PredEntry * pp)3882 found_ystop(yamop *pc, int clause_code, CODEADDR *startp, CODEADDR *endp, PredEntry *pp)
3883 {
3884 if (pc == YESCODE) {
3885 pp = RepPredProp(Yap_GetPredPropByAtom(AtomTrue,CurrentModule));
3886 *startp = (CODEADDR)YESCODE;
3887 *endp = (CODEADDR)YESCODE+(CELL)(NEXTOP((yamop *)NULL,e));
3888 return pp;
3889 }
3890 if (!pp) {
3891 /* must be an index */
3892 PredEntry **pep = (PredEntry **)pc->u.l.l;
3893 pp = pep[-1];
3894 }
3895 if (pp->PredFlags & LogUpdatePredFlag) {
3896 if (clause_code) {
3897 LogUpdClause *cl = ClauseCodeToLogUpdClause(pc->u.l.l);
3898 *startp = (CODEADDR)cl;
3899 *endp = (CODEADDR)cl+cl->ClSize;
3900 } else {
3901 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(pc->u.l.l);
3902 *startp = (CODEADDR)cl;
3903 *endp = (CODEADDR)cl+cl->ClSize;
3904 }
3905 } else if (pp->PredFlags & DynamicPredFlag) {
3906 DynamicClause *cl = ClauseCodeToDynamicClause(pc->u.l.l);
3907 *startp = (CODEADDR)cl;
3908 *endp = (CODEADDR)cl+cl->ClSize;
3909 } else {
3910 if (clause_code) {
3911 StaticClause *cl = ClauseCodeToStaticClause(pc->u.l.l);
3912 *startp = (CODEADDR)cl;
3913 *endp = (CODEADDR)cl+cl->ClSize;
3914 } else {
3915 StaticIndex *cl = ClauseCodeToStaticIndex(pc->u.l.l);
3916 *startp = (CODEADDR)cl;
3917 *endp = (CODEADDR)cl+cl->ClSize;
3918 }
3919 }
3920 return pp;
3921 }
3922
3923 static PredEntry *
ClauseInfoForCode(yamop * codeptr,CODEADDR * startp,CODEADDR * endp)3924 ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
3925 yamop *pc;
3926 PredEntry *pp = NULL;
3927 int clause_code = FALSE;
3928
3929 if (codeptr >= COMMA_CODE &&
3930 codeptr < FAILCODE) {
3931 pp = RepPredProp(Yap_GetPredPropByFunc(FunctorComma,CurrentModule));
3932 *startp = (CODEADDR)COMMA_CODE;
3933 *endp = (CODEADDR)(FAILCODE-1);
3934 return pp;
3935 }
3936 pc = codeptr;
3937 #include "walkclause.h"
3938 return NULL;
3939 }
3940
3941 PredEntry *
Yap_PredEntryForCode(yamop * codeptr,find_pred_type where_from,CODEADDR * startp,CODEADDR * endp)3942 Yap_PredEntryForCode(yamop *codeptr, find_pred_type where_from, CODEADDR *startp, CODEADDR *endp) {
3943
3944 if (where_from == FIND_PRED_FROM_CP) {
3945 PredEntry *pp = PredForChoicePt(codeptr);
3946 if (cl_code_in_pred(pp, codeptr, startp, endp)) {
3947 return pp;
3948 }
3949 } else if (where_from == FIND_PRED_FROM_ENV) {
3950 PredEntry *pp = EnvPreg(codeptr);
3951 if (cl_code_in_pred(pp, codeptr, startp, endp)) {
3952 return pp;
3953 }
3954 } else {
3955 return ClauseInfoForCode(codeptr, startp, endp);
3956 }
3957 return NULL;
3958 }
3959
3960
3961 static Int
p_pred_for_code(void)3962 p_pred_for_code(void) {
3963 yamop *codeptr;
3964 Atom at;
3965 UInt arity;
3966 Term tmodule = TermProlog;
3967 Int cl;
3968 Term t = Deref(ARG1);
3969
3970 if (IsVarTerm(t)) {
3971 return FALSE;
3972 } else if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorStaticClause) {
3973 codeptr = Yap_ClauseFromTerm(t)->ClCode;
3974 } else if (IsIntegerTerm(t)) {
3975 codeptr = (yamop *)IntegerOfTerm(t);
3976 } else if (IsDBRefTerm(t)) {
3977 codeptr = (yamop *)DBRefOfTerm(t);
3978 } else {
3979 return FALSE;
3980 }
3981 cl = PredForCode(codeptr, &at, &arity, &tmodule);
3982 if (!tmodule) tmodule = TermProlog;
3983 if (cl == 0) {
3984 return Yap_unify(ARG5,MkIntTerm(0));
3985 } else {
3986 return(Yap_unify(ARG2,MkAtomTerm(at)) &&
3987 Yap_unify(ARG3,MkIntegerTerm(arity)) &&
3988 Yap_unify(ARG4,tmodule) &&
3989 Yap_unify(ARG5,MkIntegerTerm(cl)));
3990 }
3991 }
3992
3993 static Int
p_is_profiled(void)3994 p_is_profiled(void)
3995 {
3996 Term t = Deref(ARG1);
3997 char *s;
3998
3999 if (IsVarTerm(t)) {
4000 Term ta;
4001
4002 if (PROFILING) ta = MkAtomTerm(AtomOn);
4003 else ta = MkAtomTerm(AtomOff);
4004 BIND((CELL *)t,ta,bind_is_profiled);
4005 #ifdef COROUTINING
4006 DO_TRAIL(VarOfTerm(t), ta);
4007 if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
4008 bind_is_profiled:
4009 #endif
4010 return(TRUE);
4011 } else if (!IsAtomTerm(t)) return(FALSE);
4012 s = RepAtom(AtomOfTerm(t))->StrOfAE;
4013 if (strcmp(s,"on") == 0) {
4014 PROFILING = TRUE;
4015 Yap_InitComma();
4016 return(TRUE);
4017 } else if (strcmp(s,"off") == 0) {
4018 PROFILING = FALSE;
4019 Yap_InitComma();
4020 return(TRUE);
4021 }
4022 return(FALSE);
4023 }
4024
4025 static Int
p_profile_info(void)4026 p_profile_info(void)
4027 {
4028 Term mod = Deref(ARG1);
4029 Term tfun = Deref(ARG2);
4030 Term out;
4031 PredEntry *pe;
4032 Term p[3];
4033
4034 if (IsVarTerm(mod) || !IsAtomTerm(mod))
4035 return(FALSE);
4036 if (IsVarTerm(tfun)) {
4037 return(FALSE);
4038 } else if (IsApplTerm(tfun)) {
4039 Functor f = FunctorOfTerm(tfun);
4040 if (IsExtensionFunctor(f)) {
4041 return(FALSE);
4042 }
4043 pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
4044 } else if (IsAtomTerm(tfun)) {
4045 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
4046 } else {
4047 return(FALSE);
4048 }
4049 if (EndOfPAEntr(pe))
4050 return(FALSE);
4051 LOCK(pe->StatisticsForPred.lock);
4052 if (!(pe->StatisticsForPred.NOfEntries)) {
4053 UNLOCK(pe->StatisticsForPred.lock);
4054 return(FALSE);
4055 }
4056 p[0] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfEntries);
4057 p[1] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfHeadSuccesses);
4058 p[2] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfRetries);
4059 UNLOCK(pe->StatisticsForPred.lock);
4060 out = Yap_MkApplTerm(Yap_MkFunctor(AtomProfile,3),3,p);
4061 return(Yap_unify(ARG3,out));
4062 }
4063
4064 static Int
p_profile_reset(void)4065 p_profile_reset(void)
4066 {
4067 Term mod = Deref(ARG1);
4068 Term tfun = Deref(ARG2);
4069 PredEntry *pe;
4070
4071 if (IsVarTerm(mod) || !IsAtomTerm(mod))
4072 return(FALSE);
4073 if (IsVarTerm(tfun)) {
4074 return(FALSE);
4075 } else if (IsApplTerm(tfun)) {
4076 Functor f = FunctorOfTerm(tfun);
4077 if (IsExtensionFunctor(f)) {
4078 return(FALSE);
4079 }
4080 pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
4081 } else if (IsAtomTerm(tfun)) {
4082 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
4083 } else {
4084 return(FALSE);
4085 }
4086 if (EndOfPAEntr(pe))
4087 return(FALSE);
4088 LOCK(pe->StatisticsForPred.lock);
4089 pe->StatisticsForPred.NOfEntries = 0;
4090 pe->StatisticsForPred.NOfHeadSuccesses = 0;
4091 pe->StatisticsForPred.NOfRetries = 0;
4092 UNLOCK(pe->StatisticsForPred.lock);
4093 return(TRUE);
4094 }
4095
4096 static Int
p_is_call_counted(void)4097 p_is_call_counted(void)
4098 {
4099 Term t = Deref(ARG1);
4100 char *s;
4101
4102 if (IsVarTerm(t)) {
4103 Term ta;
4104
4105 if (CALL_COUNTING) ta = MkAtomTerm(AtomOn);
4106 else ta = MkAtomTerm(AtomOff);
4107 BIND((CELL *)t,ta,bind_is_call_counted);
4108 #ifdef COROUTINING
4109 DO_TRAIL(VarOfTerm(t), ta);
4110 if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
4111 bind_is_call_counted:
4112 #endif
4113 return(TRUE);
4114 } else if (!IsAtomTerm(t)) return(FALSE);
4115 s = RepAtom(AtomOfTerm(t))->StrOfAE;
4116 if (strcmp(s,"on") == 0) {
4117 CALL_COUNTING = TRUE;
4118 Yap_InitComma();
4119 return(TRUE);
4120 } else if (strcmp(s,"off") == 0) {
4121 CALL_COUNTING = FALSE;
4122 Yap_InitComma();
4123 return(TRUE);
4124 }
4125 return(FALSE);
4126 }
4127
4128 static Int
p_call_count_info(void)4129 p_call_count_info(void)
4130 {
4131 return(Yap_unify(MkIntegerTerm(ReductionsCounter),ARG1) &&
4132 Yap_unify(MkIntegerTerm(PredEntriesCounter),ARG2) &&
4133 Yap_unify(MkIntegerTerm(PredEntriesCounter),ARG3));
4134 }
4135
4136 static Int
p_call_count_reset(void)4137 p_call_count_reset(void)
4138 {
4139 ReductionsCounter = 0;
4140 ReductionsCounterOn = FALSE;
4141 PredEntriesCounter = 0;
4142 PredEntriesCounterOn = FALSE;
4143 RetriesCounter = 0;
4144 RetriesCounterOn = FALSE;
4145 return(TRUE);
4146 }
4147
4148 static Int
p_call_count_set(void)4149 p_call_count_set(void)
4150 {
4151 int do_calls = IntOfTerm(ARG2);
4152 int do_retries = IntOfTerm(ARG4);
4153 int do_entries = IntOfTerm(ARG6);
4154
4155 if (do_calls)
4156 ReductionsCounter = IntegerOfTerm(Deref(ARG1));
4157 ReductionsCounterOn = do_calls;
4158 if (do_retries)
4159 RetriesCounter = IntegerOfTerm(Deref(ARG3));
4160 RetriesCounterOn = do_retries;
4161 if (do_entries)
4162 PredEntriesCounter = IntegerOfTerm(Deref(ARG5));
4163 PredEntriesCounterOn = do_entries;
4164 return(TRUE);
4165 }
4166
4167 static Int
p_clean_up_dead_clauses(void)4168 p_clean_up_dead_clauses(void)
4169 {
4170 while (DeadStaticClauses != NULL) {
4171 char *pt = (char *)DeadStaticClauses;
4172 Yap_ClauseSpace -= DeadStaticClauses->ClSize;
4173 DeadStaticClauses = DeadStaticClauses->ClNext;
4174 Yap_InformOfRemoval((CODEADDR)pt);
4175 Yap_FreeCodeSpace(pt);
4176 }
4177 while (DeadStaticIndices != NULL) {
4178 char *pt = (char *)DeadStaticIndices;
4179 if (DeadStaticIndices->ClFlags & SwitchTableMask)
4180 Yap_IndexSpace_SW -= DeadStaticIndices->ClSize;
4181 else
4182 Yap_IndexSpace_Tree -= DeadStaticIndices->ClSize;
4183 DeadStaticIndices = DeadStaticIndices->SiblingIndex;
4184 Yap_InformOfRemoval((CODEADDR)pt);
4185 Yap_FreeCodeSpace(pt);
4186 }
4187 while (DeadMegaClauses != NULL) {
4188 char *pt = (char *)DeadMegaClauses;
4189 Yap_ClauseSpace -= DeadMegaClauses->ClSize;
4190 DeadMegaClauses = DeadMegaClauses->ClNext;
4191 Yap_InformOfRemoval((CODEADDR)pt);
4192 Yap_FreeCodeSpace(pt);
4193 }
4194 return TRUE;
4195 }
4196
4197 static Int /* $parent_pred(Module, Name, Arity) */
p_parent_pred(void)4198 p_parent_pred(void)
4199 {
4200 /* This predicate is called from the debugger.
4201 We assume a sequence of the form a -> b */
4202 Atom at;
4203 UInt arity;
4204 Term module;
4205 if (!PredForCode(P_before_spy, &at, &arity, &module)) {
4206 return(Yap_unify(ARG1, MkIntTerm(0)) &&
4207 Yap_unify(ARG2, MkAtomTerm(AtomMetaCall)) &&
4208 Yap_unify(ARG3, MkIntTerm(0)));
4209 }
4210 return(Yap_unify(ARG1, MkIntTerm(module)) &&
4211 Yap_unify(ARG2, MkAtomTerm(at)) &&
4212 Yap_unify(ARG3, MkIntTerm(arity)));
4213 }
4214
4215 static Int /* $system_predicate(P) */
p_system_pred(void)4216 p_system_pred(void)
4217 {
4218 PredEntry *pe;
4219
4220 Term t1 = Deref(ARG1);
4221 Term mod = Deref(ARG2);
4222
4223 restart_system_pred:
4224 if (IsVarTerm(t1))
4225 return FALSE;
4226 if (IsAtomTerm(t1)) {
4227 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
4228 } else if (IsApplTerm(t1)) {
4229 Functor funt = FunctorOfTerm(t1);
4230 if (IsExtensionFunctor(funt)) {
4231 return FALSE;
4232 }
4233 if (funt == FunctorModule) {
4234 Term nmod = ArgOfTerm(1, t1);
4235 if (IsVarTerm(nmod)) {
4236 Yap_Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
4237 return FALSE;
4238 }
4239 if (!IsAtomTerm(nmod)) {
4240 Yap_Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
4241 return FALSE;
4242 }
4243 t1 = ArgOfTerm(2, t1);
4244 goto restart_system_pred;
4245 }
4246 pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
4247 } else if (IsPairTerm(t1)) {
4248 return TRUE;
4249 } else
4250 return FALSE;
4251 if (EndOfPAEntr(pe))
4252 return FALSE;
4253 return(!pe->ModuleOfPred || /* any predicate in prolog module */
4254 /* any C-pred */
4255 pe->PredFlags & (UserCPredFlag|CPredFlag|BinaryPredFlag|AsmPredFlag|TestPredFlag) ||
4256 /* any weird user built-in */
4257 pe->OpcodeOfPred == Yap_opcode(_try_userc));
4258 }
4259
4260 static Int /* $system_predicate(P) */
p_all_system_pred(void)4261 p_all_system_pred(void)
4262 {
4263 PredEntry *pe;
4264
4265 Term t1 = Deref(ARG1);
4266 Term mod = Deref(ARG2);
4267
4268 restart_system_pred:
4269 if (IsVarTerm(t1))
4270 return TRUE;
4271 if (IsAtomTerm(t1)) {
4272 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
4273 } else if (IsApplTerm(t1)) {
4274 Functor funt = FunctorOfTerm(t1);
4275 if (IsExtensionFunctor(funt)) {
4276 return FALSE;
4277 }
4278 if (funt == FunctorModule) {
4279 Term nmod = ArgOfTerm(1, t1);
4280 if (IsVarTerm(nmod)) {
4281 Yap_Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
4282 return FALSE;
4283 }
4284 if (!IsAtomTerm(nmod)) {
4285 Yap_Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
4286 return FALSE;
4287 }
4288 t1 = ArgOfTerm(2, t1);
4289 goto restart_system_pred;
4290 }
4291 pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
4292 } else if (IsPairTerm(t1)) {
4293 return TRUE;
4294 } else
4295 return FALSE;
4296 if (EndOfPAEntr(pe))
4297 return FALSE;
4298 if (pe->ModuleOfPred) {
4299 if (!Yap_unify(ARG3,pe->ModuleOfPred))
4300 return FALSE;
4301 } else {
4302 if (!Yap_unify(ARG3,TermProlog))
4303 return FALSE;
4304 }
4305 return(!pe->ModuleOfPred || /* any predicate in prolog module */
4306 /* any C-pred */
4307 pe->PredFlags & (UserCPredFlag|CPredFlag|BinaryPredFlag|AsmPredFlag|TestPredFlag) ||
4308 /* any weird user built-in */
4309 pe->OpcodeOfPred == Yap_opcode(_try_userc));
4310 }
4311
4312 static Int /* $system_predicate(P) */
p_hide_predicate(void)4313 p_hide_predicate(void)
4314 {
4315 PredEntry *pe;
4316
4317 Term t1 = Deref(ARG1);
4318 Term mod = Deref(ARG2);
4319
4320 restart_system_pred:
4321 if (IsVarTerm(t1))
4322 return (FALSE);
4323 if (IsAtomTerm(t1)) {
4324 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
4325 } else if (IsApplTerm(t1)) {
4326 Functor funt = FunctorOfTerm(t1);
4327 if (IsExtensionFunctor(funt)) {
4328 return(FALSE);
4329 }
4330 if (funt == FunctorModule) {
4331 Term nmod = ArgOfTerm(1, t1);
4332 if (IsVarTerm(nmod)) {
4333 Yap_Error(INSTANTIATION_ERROR,ARG1,"hide_predicate/1");
4334 return(FALSE);
4335 }
4336 if (!IsAtomTerm(nmod)) {
4337 Yap_Error(TYPE_ERROR_ATOM,ARG1,"hide_predicate/1");
4338 return(FALSE);
4339 }
4340 t1 = ArgOfTerm(2, t1);
4341 goto restart_system_pred;
4342 }
4343 pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
4344 } else if (IsPairTerm(t1)) {
4345 return (TRUE);
4346 } else
4347 return (FALSE);
4348 if (EndOfPAEntr(pe))
4349 return FALSE;
4350 pe->PredFlags |= HiddenPredFlag;
4351 return(TRUE);
4352 }
4353
4354 static Int /* $hidden_predicate(P) */
p_hidden_predicate(void)4355 p_hidden_predicate(void)
4356 {
4357 PredEntry *pe;
4358
4359 Term t1 = Deref(ARG1);
4360 Term mod = Deref(ARG2);
4361
4362 restart_system_pred:
4363 if (IsVarTerm(t1))
4364 return (FALSE);
4365 if (IsAtomTerm(t1)) {
4366 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
4367 } else if (IsApplTerm(t1)) {
4368 Functor funt = FunctorOfTerm(t1);
4369 if (IsExtensionFunctor(funt)) {
4370 return(FALSE);
4371 }
4372 if (funt == FunctorModule) {
4373 Term nmod = ArgOfTerm(1, t1);
4374 if (IsVarTerm(nmod)) {
4375 Yap_Error(INSTANTIATION_ERROR,ARG1,"hide_predicate/1");
4376 return(FALSE);
4377 }
4378 if (!IsAtomTerm(nmod)) {
4379 Yap_Error(TYPE_ERROR_ATOM,ARG1,"hide_predicate/1");
4380 return(FALSE);
4381 }
4382 t1 = ArgOfTerm(2, t1);
4383 goto restart_system_pred;
4384 }
4385 pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
4386 } else if (IsPairTerm(t1)) {
4387 return (TRUE);
4388 } else
4389 return (FALSE);
4390 if (EndOfPAEntr(pe))
4391 return(FALSE);
4392 return(pe->PredFlags & HiddenPredFlag);
4393 }
4394
4395 static Int
fetch_next_lu_clause(PredEntry * pe,yamop * i_code,Term th,Term tb,Term tr,yamop * cp_ptr,int first_time)4396 fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
4397 {
4398 LogUpdClause *cl;
4399 Term rtn;
4400 Term Terms[3];
4401
4402 Terms[0] = th;
4403 Terms[1] = tb;
4404 Terms[2] = tr;
4405 cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClause->CodeOfPred,Otapl), cp_ptr);
4406 th = Terms[0];
4407 tb = Terms[1];
4408 tr = Terms[2];
4409 /* don't do this!! I might have stored a choice-point and changed ASP
4410 Yap_RecoverSlots(3);
4411 */
4412 if (cl == NULL) {
4413 UNLOCK(pe->PELock);
4414 return FALSE;
4415 }
4416 rtn = MkDBRefTerm((DBRef)cl);
4417 #if defined(YAPOR) || defined(THREADS)
4418 TRAIL_CLREF(cl); /* So that fail will erase it */
4419 INC_CLREF_COUNT(cl);
4420 #else
4421 if (!(cl->ClFlags & InUseMask)) {
4422 cl->ClFlags |= InUseMask;
4423 TRAIL_CLREF(cl); /* So that fail will erase it */
4424 }
4425 #endif
4426 if (cl->ClFlags & FactMask) {
4427 if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
4428 !Yap_unify(tr, rtn)) {
4429 UNLOCK(pe->PELock);
4430 return FALSE;
4431 }
4432 if (pe->ArityOfPE) {
4433 Functor f = FunctorOfTerm(th);
4434 UInt arity = ArityOfFunctor(f), i;
4435 CELL *pt = RepAppl(th)+1;
4436
4437 for (i=0; i<arity; i++) {
4438 XREGS[i+1] = pt[i];
4439 }
4440 /* don't need no ENV */
4441 if (first_time &&
4442 P->opc != EXECUTE_CPRED_OP_CODE) {
4443 CP = P;
4444 ENV = YENV;
4445 YENV = ASP;
4446 YENV[E_CB] = (CELL) B;
4447
4448 }
4449 P = cl->ClCode;
4450 #if defined(YAPOR) || defined(THREADS)
4451 if (pe->PredFlags & ThreadLocalPredFlag) {
4452 /* we don't actually need to execute code */
4453 UNLOCK(pe->PELock);
4454 } else {
4455 PP = pe;
4456 }
4457 #endif
4458 } else {
4459 /* we don't actually need to execute code */
4460 UNLOCK(pe->PELock);
4461 }
4462 return TRUE;
4463 } else {
4464 Term t;
4465
4466 while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
4467 if (first_time) {
4468 ARG5 = th;
4469 ARG6 = tb;
4470 ARG7 = tr;
4471 if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
4472 Yap_Error_TYPE = YAP_NO_ERROR;
4473 if (!Yap_growglobal(NULL)) {
4474 UNLOCK(pe->PELock);
4475 Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
4476 return FALSE;
4477 }
4478 } else {
4479 Yap_Error_TYPE = YAP_NO_ERROR;
4480 if (!Yap_gcl(Yap_Error_Size, 7, ENV, gc_P(P,CP))) {
4481 UNLOCK(pe->PELock);
4482 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4483 return FALSE;
4484 }
4485 }
4486 th = ARG5;
4487 tb = ARG6;
4488 tr = ARG7;
4489 } else {
4490 ARG6 = th;
4491 ARG7 = tb;
4492 ARG8 = tr;
4493 if (!Yap_gcl(Yap_Error_Size, 8, ENV, gc_P(P,CP))) {
4494 UNLOCK(pe->PELock);
4495 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4496 return FALSE;
4497 }
4498 th = ARG6;
4499 tb = ARG7;
4500 tr = ARG8;
4501 }
4502 }
4503 UNLOCK(pe->PELock);
4504 return(Yap_unify(th, ArgOfTerm(1,t)) &&
4505 Yap_unify(tb, ArgOfTerm(2,t)) &&
4506 Yap_unify(tr, rtn));
4507 }
4508 }
4509
4510 static Int /* $hidden_predicate(P) */
p_log_update_clause(void)4511 p_log_update_clause(void)
4512 {
4513 PredEntry *pe;
4514 Term t1 = Deref(ARG1);
4515 Int ret;
4516 yamop *new_cp;
4517
4518 if (P->opc == EXECUTE_CPRED_OP_CODE) {
4519 new_cp = CP;
4520 } else {
4521 new_cp = P;
4522 }
4523 pe = get_pred(t1, Deref(ARG2), "clause/3");
4524 if (pe == NULL || EndOfPAEntr(pe))
4525 return FALSE;
4526 PELOCK(41,pe);
4527 ret = fetch_next_lu_clause(pe, pe->CodeOfPred, t1, ARG3, ARG4, new_cp, TRUE);
4528 return ret;
4529 }
4530
4531 static Int /* $hidden_predicate(P) */
p_continue_log_update_clause(void)4532 p_continue_log_update_clause(void)
4533 {
4534 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
4535 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
4536
4537 PELOCK(42,pe);
4538 return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
4539 }
4540
4541 static Int
fetch_next_lu_clause_erase(PredEntry * pe,yamop * i_code,Term th,Term tb,Term tr,yamop * cp_ptr,int first_time)4542 fetch_next_lu_clause_erase(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
4543 {
4544 LogUpdClause *cl;
4545 Term rtn;
4546 Term Terms[3];
4547
4548 Terms[0] = th;
4549 Terms[1] = tb;
4550 Terms[2] = tr;
4551 cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClauseErase->CodeOfPred,Otapl), cp_ptr);
4552 th = Terms[0];
4553 tb = Terms[1];
4554 tr = Terms[2];
4555 /* don't do this!! I might have stored a choice-point and changed ASP
4556 Yap_RecoverSlots(3);
4557 */
4558 if (cl == NULL) {
4559 UNLOCK(pe->PELock);
4560 return FALSE;
4561 }
4562 rtn = MkDBRefTerm((DBRef)cl);
4563 #if defined(YAPOR) || defined(THREADS)
4564 TRAIL_CLREF(cl); /* So that fail will erase it */
4565 INC_CLREF_COUNT(cl);
4566 #else
4567 if (!(cl->ClFlags & InUseMask)) {
4568 cl->ClFlags |= InUseMask;
4569 TRAIL_CLREF(cl); /* So that fail will erase it */
4570 }
4571 #endif
4572 if (cl->ClFlags & FactMask) {
4573 if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
4574 !Yap_unify(tr, rtn)) {
4575 UNLOCK(pe->PELock);
4576 return FALSE;
4577 }
4578 if (pe->ArityOfPE) {
4579 Functor f = FunctorOfTerm(th);
4580 UInt arity = ArityOfFunctor(f), i;
4581 CELL *pt = RepAppl(th)+1;
4582
4583 for (i=0; i<arity; i++) {
4584 XREGS[i+1] = pt[i];
4585 }
4586 /* don't need no ENV */
4587 if (first_time &&
4588 P->opc != EXECUTE_CPRED_OP_CODE) {
4589 CP = P;
4590 ENV = YENV;
4591 YENV = ASP;
4592 YENV[E_CB] = (CELL) B;
4593 }
4594 P = cl->ClCode;
4595 #if defined(YAPOR) || defined(THREADS)
4596 if (pe->PredFlags & ThreadLocalPredFlag) {
4597 /* we don't actually need to execute code */
4598 UNLOCK(pe->PELock);
4599 } else {
4600 PP = pe;
4601 }
4602 #endif
4603 } else {
4604 /* we don't actually need to execute code */
4605 UNLOCK(pe->PELock);
4606 }
4607 Yap_ErLogUpdCl(cl);
4608 return TRUE;
4609 } else {
4610 Term t;
4611 Int res;
4612
4613 while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
4614 if (first_time) {
4615 ARG5 = th;
4616 ARG6 = tb;
4617 ARG7 = tr;
4618 if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
4619 Yap_Error_TYPE = YAP_NO_ERROR;
4620 if (!Yap_growglobal(NULL)) {
4621 UNLOCK(pe->PELock);
4622 Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
4623 return FALSE;
4624 }
4625 } else {
4626 Yap_Error_TYPE = YAP_NO_ERROR;
4627 if (!Yap_gcl(Yap_Error_Size, 7, ENV, gc_P(P,CP))) {
4628 UNLOCK(pe->PELock);
4629 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4630 return FALSE;
4631 }
4632 }
4633 th = ARG5;
4634 tb = ARG6;
4635 tr = ARG7;
4636 } else {
4637 ARG6 = th;
4638 ARG7 = tb;
4639 ARG8 = tr;
4640 if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
4641 UNLOCK(pe->PELock);
4642 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4643 return FALSE;
4644 }
4645 th = ARG6;
4646 tb = ARG7;
4647 tr = ARG8;
4648 }
4649 }
4650 res = Yap_unify(th, ArgOfTerm(1,t)) &&
4651 Yap_unify(tb, ArgOfTerm(2,t)) &&
4652 Yap_unify(tr, rtn);
4653 if (res)
4654 Yap_ErLogUpdCl(cl);
4655 UNLOCK(pe->PELock);
4656 return res;
4657 }
4658 }
4659
4660 static Int /* $hidden_predicate(P) */
p_log_update_clause_erase(void)4661 p_log_update_clause_erase(void)
4662 {
4663 PredEntry *pe;
4664 Term t1 = Deref(ARG1);
4665 Int ret;
4666 yamop *new_cp;
4667
4668 if (P->opc == EXECUTE_CPRED_OP_CODE) {
4669 new_cp = CP;
4670 } else {
4671 new_cp = P;
4672 }
4673 pe = get_pred(t1, Deref(ARG2), "clause/3");
4674 if (pe == NULL || EndOfPAEntr(pe))
4675 return FALSE;
4676 PELOCK(43,pe);
4677 ret = fetch_next_lu_clause_erase(pe, pe->CodeOfPred, t1, ARG3, ARG4, new_cp, TRUE);
4678 return ret;
4679 }
4680
4681 static Int /* $hidden_predicate(P) */
p_continue_log_update_clause_erase(void)4682 p_continue_log_update_clause_erase(void)
4683 {
4684 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
4685 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
4686
4687 PELOCK(44,pe);
4688 return fetch_next_lu_clause_erase(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
4689 }
4690
4691 static void
adjust_cl_timestamp(LogUpdClause * cl,UInt * arp,UInt * base)4692 adjust_cl_timestamp(LogUpdClause *cl, UInt *arp, UInt *base)
4693 {
4694 UInt clstamp = cl->ClTimeEnd;
4695 if (cl->ClTimeEnd != TIMESTAMP_EOT) {
4696 while (arp[0] > clstamp)
4697 arp--;
4698 if (arp[0] == clstamp) {
4699 cl->ClTimeEnd = (arp-base);
4700 } else {
4701 cl->ClTimeEnd = (arp-base)+1;
4702 }
4703 }
4704 clstamp = cl->ClTimeStart;
4705 while (arp[0] > clstamp)
4706 arp--;
4707 if (arp[0] == clstamp) {
4708 cl->ClTimeStart = (arp-base);
4709 } else {
4710 cl->ClTimeStart = (arp-base)+1;
4711 }
4712 clstamp = cl->ClTimeEnd;
4713 }
4714
4715
4716 static Term
replace_integer(Term orig,UInt new)4717 replace_integer(Term orig, UInt new)
4718 {
4719 CELL *pt;
4720
4721 if (IntInBnd((Int)new))
4722 return MkIntTerm(new);
4723 /* should create an old integer */
4724 if (!IsApplTerm(orig)) {
4725 Yap_Error(SYSTEM_ERROR,orig,"%uld-->%uld where it should increase",(unsigned long int)IntegerOfTerm(orig),(unsigned long int)new);
4726 return MkIntegerTerm(new);
4727 }
4728 /* appl->appl */
4729 /* replace integer in situ */
4730 pt = RepAppl(orig)+1;
4731 *pt = new;
4732 return orig;
4733 }
4734
4735 void /* $hidden_predicate(P) */
Yap_UpdateTimestamps(PredEntry * ap)4736 Yap_UpdateTimestamps(PredEntry *ap)
4737 {
4738 choiceptr bptr = B;
4739 yamop *cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,Otapl);
4740 yamop *cl = NEXTOP(PredLogUpdClause->CodeOfPred,Otapl);
4741 yamop *cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,Otapl);
4742 UInt ar = ap->ArityOfPE;
4743 UInt *arp, *top, *base;
4744 LogUpdClause *lcl;
4745
4746 #if THREADS
4747 Yap_Error(SYSTEM_ERROR,TermNil,"Timestamp overflow %p", ap);
4748 return;
4749 #endif
4750 if (!ap->cs.p_code.NOfClauses)
4751 return;
4752 restart:
4753 *--ASP = TIMESTAMP_EOT;
4754 top = arp = (UInt *)ASP;
4755 while (bptr) {
4756 op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
4757
4758 switch (opnum) {
4759 case _retry_logical:
4760 case _count_retry_logical:
4761 case _profiled_retry_logical:
4762 case _trust_logical:
4763 case _count_trust_logical:
4764 case _profiled_trust_logical:
4765 if (bptr->cp_ap->u.OtaLl.d->ClPred == ap) {
4766 UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
4767 if (ts != arp[0]) {
4768 if (arp-H < 1024) {
4769 goto overflow;
4770 }
4771 /* be thrifty, have this in case there is a hole */
4772 if (ts != arp[0]-1) {
4773 UInt x = arp[0];
4774 *--arp = x;
4775 }
4776 *--arp = ts;
4777 }
4778 }
4779 bptr = bptr->cp_b;
4780 break;
4781 case _retry:
4782 if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
4783 ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
4784 UInt ts = IntegerOfTerm(bptr->cp_args[5]);
4785 if (ts != arp[0]) {
4786 if (arp-H < 1024) {
4787 goto overflow;
4788 }
4789 if (ts != arp[0]-1) {
4790 UInt x = arp[0];
4791 *--arp = x;
4792 }
4793 *--arp = ts;
4794 }
4795 }
4796 bptr = bptr->cp_b;
4797 break;
4798 default:
4799 bptr = bptr->cp_b;
4800 continue;
4801 }
4802 }
4803 if (*arp)
4804 *--arp = 0L;
4805 base = arp;
4806 lcl = ClauseCodeToLogUpdClause(ap->cs.p_code.FirstClause);
4807 while (lcl) {
4808 adjust_cl_timestamp(lcl, top-1, base);
4809 lcl = lcl->ClNext;
4810 }
4811 lcl = DBErasedList;
4812 while (lcl) {
4813 if (lcl->ClPred == ap)
4814 adjust_cl_timestamp(lcl, top-1, base);
4815 lcl = lcl->ClNext;
4816 }
4817 arp = top-1;
4818 bptr = B;
4819 while (bptr) {
4820 op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
4821
4822 switch (opnum) {
4823 case _retry_logical:
4824 case _count_retry_logical:
4825 case _profiled_retry_logical:
4826 case _trust_logical:
4827 case _count_trust_logical:
4828 case _profiled_trust_logical:
4829 if (bptr->cp_ap->u.OtaLl.d->ClPred == ap) {
4830 UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
4831 while (ts != arp[0])
4832 arp--;
4833 bptr->cp_args[ar] = replace_integer(bptr->cp_args[ar], arp-base);
4834 }
4835 bptr = bptr->cp_b;
4836 break;
4837 case _retry:
4838 if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
4839 ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
4840 UInt ts = IntegerOfTerm(bptr->cp_args[5]);
4841 while (ts != arp[0])
4842 arp--;
4843 bptr->cp_args[5] = replace_integer(bptr->cp_args[5], arp-base);
4844 }
4845 bptr = bptr->cp_b;
4846 break;
4847 default:
4848 bptr = bptr->cp_b;
4849 continue;
4850 }
4851 }
4852 return;
4853 overflow:
4854 if (!Yap_growstack(64*1024)) {
4855 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4856 return;
4857 }
4858 goto restart;
4859 }
4860
4861 static Int
fetch_next_static_clause(PredEntry * pe,yamop * i_code,Term th,Term tb,Term tr,yamop * cp_ptr,int first_time)4862 fetch_next_static_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
4863 {
4864 StaticClause *cl;
4865 Term rtn;
4866 Term Terms[3];
4867
4868 Terms[0] = th;
4869 Terms[1] = tb;
4870 Terms[2] = tr;
4871 cl = (StaticClause *)Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredStaticClause->CodeOfPred,Otapl), cp_ptr);
4872 th = Deref(Terms[0]);
4873 tb = Deref(Terms[1]);
4874 tr = Deref(Terms[2]);
4875 /* don't do this!! I might have stored a choice-point and changed ASP
4876 Yap_RecoverSlots(3);
4877 */
4878 if (cl == NULL) {
4879 UNLOCKPE(45,pe);
4880 return FALSE;
4881 }
4882 if (pe->PredFlags & MegaClausePredFlag) {
4883 yamop *code = (yamop *)cl;
4884 rtn = Yap_MkMegaRefTerm(pe,code);
4885 if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
4886 !Yap_unify(tr, rtn)) {
4887 UNLOCKPE(45,pe);
4888 return FALSE;
4889 }
4890 if (pe->ArityOfPE) {
4891 Functor f = FunctorOfTerm(th);
4892 UInt arity = ArityOfFunctor(f), i;
4893 CELL *pt = RepAppl(th)+1;
4894
4895 for (i=0; i<arity; i++) {
4896 XREGS[i+1] = pt[i];
4897 }
4898 /* don't need no ENV */
4899 if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
4900 CP = P;
4901 ENV = YENV;
4902 YENV = ASP;
4903 YENV[E_CB] = (CELL) B;
4904 }
4905 P = code;
4906 }
4907 return TRUE;
4908 }
4909 rtn = Yap_MkStaticRefTerm(cl);
4910 if (cl->ClFlags & FactMask) {
4911 if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
4912 !Yap_unify(tr, rtn)) {
4913 UNLOCKPE(45,pe);
4914 return FALSE;
4915 }
4916
4917 if (pe->ArityOfPE) {
4918 Functor f = FunctorOfTerm(th);
4919 UInt arity = ArityOfFunctor(f), i;
4920 CELL *pt = RepAppl(th)+1;
4921
4922 for (i=0; i<arity; i++) {
4923 XREGS[i+1] = pt[i];
4924 }
4925 /* don't need no ENV */
4926 if (first_time &&
4927 P->opc != EXECUTE_CPRED_OP_CODE) {
4928 CP = P;
4929 ENV = YENV;
4930 YENV = ASP;
4931 YENV[E_CB] = (CELL) B;
4932 }
4933 P = cl->ClCode;
4934 }
4935 UNLOCKPE(45,pe);
4936 return TRUE;
4937 } else {
4938 Term t;
4939
4940 if (!(pe->PredFlags & SourcePredFlag)) {
4941 /* no source */
4942 rtn = Yap_MkStaticRefTerm(cl);
4943 UNLOCKPE(45,pe);
4944 return Yap_unify(tr, rtn);
4945 }
4946
4947 if (!(pe->PredFlags & SourcePredFlag)) {
4948 rtn = Yap_MkStaticRefTerm(cl);
4949 return Yap_unify(tr, rtn);
4950 }
4951 while ((t = Yap_FetchTermFromDB(cl->usc.ClSource)) == 0L) {
4952 if (first_time) {
4953 if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
4954 Yap_Error_TYPE = YAP_NO_ERROR;
4955 if (!Yap_growglobal(NULL)) {
4956 Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
4957 return FALSE;
4958 }
4959 } else {
4960 Yap_Error_TYPE = YAP_NO_ERROR;
4961 ARG5 = th;
4962 ARG6 = tb;
4963 ARG7 = tr;
4964 if (!Yap_gc(7, ENV, gc_P(P,CP))) {
4965 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4966 return FALSE;
4967 }
4968 th = ARG5;
4969 tb = ARG6;
4970 tr = ARG7;
4971 }
4972 } else {
4973 Yap_Error_TYPE = YAP_NO_ERROR;
4974 ARG6 = th;
4975 ARG7 = tb;
4976 ARG8 = tr;
4977 if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
4978 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
4979 return FALSE;
4980 }
4981 th = ARG6;
4982 tb = ARG7;
4983 tr = ARG8;
4984 }
4985 }
4986 rtn = Yap_MkStaticRefTerm(cl);
4987 UNLOCKPE(45,pe);
4988 if (!IsApplTerm(t) || FunctorOfTerm(t) != FunctorAssert) {
4989 return(Yap_unify(th, t) &&
4990 Yap_unify(tb, MkAtomTerm(AtomTrue)) &&
4991 Yap_unify(tr, rtn));
4992 } else {
4993 return(Yap_unify(th, ArgOfTerm(1,t)) &&
4994 Yap_unify(tb, ArgOfTerm(2,t)) &&
4995 Yap_unify(tr, rtn));
4996 }
4997 }
4998 }
4999
5000 static Int /* $hidden_predicate(P) */
p_static_clause(void)5001 p_static_clause(void)
5002 {
5003 PredEntry *pe;
5004 Term t1 = Deref(ARG1);
5005 yamop * new_cp;
5006
5007 if (P->opc == EXECUTE_CPRED_OP_CODE) {
5008 new_cp = CP;
5009 } else {
5010 new_cp = P;
5011 }
5012 pe = get_pred(t1, Deref(ARG2), "clause/3");
5013 if (pe == NULL || EndOfPAEntr(pe))
5014 return FALSE;
5015 PELOCK(46,pe);
5016 return fetch_next_static_clause(pe, pe->CodeOfPred, ARG1, ARG3, ARG4, new_cp, TRUE);
5017 }
5018
5019 static Int /* $hidden_predicate(P) */
p_nth_clause(void)5020 p_nth_clause(void)
5021 {
5022 PredEntry *pe;
5023 Term t1 = Deref(ARG1);
5024 Term tn = Deref(ARG3);
5025 LogUpdClause *cl;
5026 Int ncls;
5027
5028 if (!IsIntegerTerm(tn))
5029 return FALSE;
5030 ncls = IntegerOfTerm(tn);
5031 pe = get_pred(t1, Deref(ARG2), "clause/3");
5032 if (pe == NULL || EndOfPAEntr(pe))
5033 return FALSE;
5034 PELOCK(47,pe);
5035 if (!(pe->PredFlags & (SourcePredFlag|LogUpdatePredFlag))) {
5036 return FALSE;
5037 }
5038 /* in case we have to index or to expand code */
5039 if (pe->ModuleOfPred != IDB_MODULE) {
5040 UInt i;
5041
5042 for (i = 1; i <= pe->ArityOfPE; i++) {
5043 XREGS[i] = MkVarTerm();
5044 }
5045 } else {
5046 XREGS[2] = MkVarTerm();
5047 }
5048 if(pe->OpcodeOfPred == INDEX_OPCODE) {
5049 IPred(pe, 0, CP);
5050 }
5051 cl = Yap_NthClause(pe, ncls);
5052 if (cl == NULL) {
5053 UNLOCK(pe->PELock);
5054 return FALSE;
5055 }
5056 if (pe->PredFlags & LogUpdatePredFlag) {
5057 #if defined(YAPOR) || defined(THREADS)
5058 TRAIL_CLREF(cl); /* So that fail will erase it */
5059 INC_CLREF_COUNT(cl);
5060 #else
5061 if (!(cl->ClFlags & InUseMask)) {
5062 cl->ClFlags |= InUseMask;
5063 TRAIL_CLREF(cl); /* So that fail will erase it */
5064 }
5065 #endif
5066 UNLOCK(pe->PELock);
5067 return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
5068 } else if (pe->PredFlags & MegaClausePredFlag) {
5069 UNLOCK(pe->PELock);
5070 return Yap_unify(Yap_MkMegaRefTerm(pe,(yamop *)cl), ARG4);
5071 } else {
5072 UNLOCK(pe->PELock);
5073 return Yap_unify(Yap_MkStaticRefTerm((StaticClause *)cl), ARG4);
5074 }
5075 }
5076
5077 static Int /* $hidden_predicate(P) */
p_continue_static_clause(void)5078 p_continue_static_clause(void)
5079 {
5080 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
5081 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
5082
5083 PELOCK(48,pe);
5084 return fetch_next_static_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_ap, FALSE);
5085 }
5086
5087 #if LOW_PROF
5088
5089 static void
add_code_in_lu_index(LogUpdIndex * cl,PredEntry * pp)5090 add_code_in_lu_index(LogUpdIndex *cl, PredEntry *pp)
5091 {
5092 char *code_end = (char *)cl + cl->ClSize;
5093 Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
5094 cl = cl->ChildIndex;
5095 while (cl != NULL) {
5096 add_code_in_lu_index(cl, pp);
5097 cl = cl->SiblingIndex;
5098 }
5099 }
5100
5101 static void
add_code_in_static_index(StaticIndex * cl,PredEntry * pp)5102 add_code_in_static_index(StaticIndex *cl, PredEntry *pp)
5103 {
5104 char *code_end = (char *)cl + cl->ClSize;
5105 Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
5106 cl = cl->ChildIndex;
5107 while (cl != NULL) {
5108 add_code_in_static_index(cl, pp);
5109 cl = cl->SiblingIndex;
5110 }
5111 }
5112
5113
5114 static void
add_code_in_pred(PredEntry * pp)5115 add_code_in_pred(PredEntry *pp) {
5116 yamop *clcode;
5117
5118 PELOCK(49,pp);
5119 /* check if the codeptr comes from the indexing code */
5120
5121 /* highly likely this is used for indexing */
5122 Yap_inform_profiler_of_clause((yamop *)&(pp->OpcodeOfPred), (yamop *)(&(pp->OpcodeOfPred)+1), pp, 1);
5123 if (pp->PredFlags & (CPredFlag|AsmPredFlag)) {
5124 char *code_end;
5125 StaticClause *cl;
5126
5127 clcode = pp->CodeOfPred;
5128 cl = ClauseCodeToStaticClause(clcode);
5129 code_end = (char *)cl + cl->ClSize;
5130 Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0);
5131 UNLOCK(pp->PELock);
5132 return;
5133 }
5134 Yap_inform_profiler_of_clause((yamop *)&(pp->cs.p_code.ExpandCode), (yamop *)(&(pp->cs.p_code.ExpandCode)+1), pp, 1);
5135 clcode = pp->cs.p_code.TrueCodeOfPred;
5136 if (pp->PredFlags & IndexedPredFlag) {
5137 if (pp->PredFlags & LogUpdatePredFlag) {
5138 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(clcode);
5139 add_code_in_lu_index(cl, pp);
5140 } else {
5141 StaticIndex *cl = ClauseCodeToStaticIndex(clcode);
5142 add_code_in_static_index(cl, pp);
5143 }
5144 }
5145 clcode = pp->cs.p_code.FirstClause;
5146 if (clcode != NULL) {
5147 if (pp->PredFlags & LogUpdatePredFlag) {
5148 LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
5149 do {
5150 char *code_end;
5151
5152 code_end = (char *)cl + cl->ClSize;
5153 Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
5154 cl = cl->ClNext;
5155 } while (cl != NULL);
5156 } else if (pp->PredFlags & DynamicPredFlag) {
5157 do {
5158 DynamicClause *cl;
5159 CODEADDR code_end;
5160
5161 cl = ClauseCodeToDynamicClause(clcode);
5162 code_end = (CODEADDR)cl + cl->ClSize;
5163 Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0);
5164 if (clcode == pp->cs.p_code.LastClause)
5165 break;
5166 clcode = NextDynamicClause(clcode);
5167 } while (TRUE);
5168 } else {
5169 StaticClause *cl = ClauseCodeToStaticClause(clcode);
5170 do {
5171 char *code_end;
5172
5173 code_end = (char *)cl + cl->ClSize;
5174 Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
5175 if (cl->ClCode == pp->cs.p_code.LastClause)
5176 break;
5177 cl = cl->ClNext;
5178 } while (TRUE);
5179 }
5180 }
5181 UNLOCK(pp->PELock);
5182 }
5183
5184
5185 void
Yap_dump_code_area_for_profiler(void)5186 Yap_dump_code_area_for_profiler(void) {
5187 ModEntry *me = CurrentModules;
5188
5189 while (me) {
5190 PredEntry *pp = me->PredForME;
5191
5192 while (pp != NULL) {
5193 /* if (pp->ArityOfPE) {
5194 fprintf(stderr,"%s/%d %p\n",
5195 RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE,
5196 pp->ArityOfPE,
5197 pp);
5198 } else {
5199 fprintf(stderr,"%s %p\n",
5200 RepAtom((Atom)(pp->FunctorOfPred))->StrOfAE,
5201 pp);
5202 }*/
5203 add_code_in_pred(pp);
5204 pp = pp->NextPredOfModule;
5205 }
5206 me = me->NextME;
5207 }
5208 Yap_inform_profiler_of_clause(COMMA_CODE, FAILCODE, RepPredProp(Yap_GetPredPropByFunc(FunctorComma,0)),0);
5209 Yap_inform_profiler_of_clause(FAILCODE, FAILCODE+1, RepPredProp(Yap_GetPredPropByAtom(AtomFail,0)),0);
5210 }
5211
5212 #endif /* LOW_PROF */
5213
5214 static UInt
index_ssz(StaticIndex * x)5215 index_ssz(StaticIndex *x)
5216 {
5217 UInt sz = x->ClSize;
5218 x = x->ChildIndex;
5219 while (x != NULL) {
5220 sz += index_ssz(x);
5221 x = x->SiblingIndex;
5222 }
5223 return sz;
5224 }
5225
5226 static Int
static_statistics(PredEntry * pe)5227 static_statistics(PredEntry *pe)
5228 {
5229 UInt sz = 0, cls = 0, isz = 0;
5230 StaticClause *cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
5231
5232 if (pe->cs.p_code.NOfClauses > 1 &&
5233 pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause) {
5234 isz = index_ssz(ClauseCodeToStaticIndex(pe->cs.p_code.TrueCodeOfPred));
5235 }
5236 if (pe->PredFlags & MegaClausePredFlag) {
5237 MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
5238 return Yap_unify(ARG3, MkIntegerTerm(mcl->ClSize/mcl->ClItemSize)) &&
5239 Yap_unify(ARG4, MkIntegerTerm(mcl->ClSize)) &&
5240 Yap_unify(ARG5, MkIntegerTerm(isz));
5241 }
5242 if (pe->cs.p_code.NOfClauses) {
5243 do {
5244 cls++;
5245 sz += cl->ClSize;
5246 if (cl->ClCode == pe->cs.p_code.LastClause)
5247 break;
5248 cl = cl->ClNext;
5249 } while (TRUE);
5250 }
5251 return Yap_unify(ARG3, MkIntegerTerm(cls)) &&
5252 Yap_unify(ARG4, MkIntegerTerm(sz)) &&
5253 Yap_unify(ARG5, MkIntegerTerm(isz));
5254 }
5255
5256 static Int
p_static_pred_statistics(void)5257 p_static_pred_statistics(void)
5258 {
5259 Int out;
5260 PredEntry *pe;
5261
5262 pe = get_pred( Deref(ARG1), Deref(ARG2), "predicate_statistics");
5263 if (pe == NIL)
5264 return (FALSE);
5265 PELOCK(50,pe);
5266 if (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) {
5267 /* should use '$recordedp' in this case */
5268 UNLOCK(pe->PELock);
5269 return FALSE;
5270 }
5271 out = static_statistics(pe);
5272 UNLOCK(pe->PELock);
5273 return out;
5274 }
5275
5276 static Int
p_predicate_erased_statistics(void)5277 p_predicate_erased_statistics(void)
5278 {
5279 UInt sz = 0, cls = 0;
5280 UInt isz = 0, icls = 0;
5281 PredEntry *pe;
5282 LogUpdClause *cl = DBErasedList;
5283 LogUpdIndex *icl = DBErasedIList;
5284 Term tpred = ArgOfTerm(2,Deref(ARG1));
5285 Term tmod = ArgOfTerm(1,Deref(ARG1));
5286
5287 if (EndOfPAEntr(pe=get_pred(tpred, tmod, "predicate_erased_statistics")))
5288 return FALSE;
5289 while (cl) {
5290 if (cl->ClPred == pe) {
5291 cls++;
5292 sz += cl->ClSize;
5293 }
5294 cl = cl->ClNext;
5295 }
5296 while (icl) {
5297 if (pe == icl->ClPred) {
5298 icls++;
5299 isz += icl->ClSize;
5300 }
5301 icl = icl->SiblingIndex;
5302 }
5303 return
5304 Yap_unify(ARG2,MkIntegerTerm(cls)) &&
5305 Yap_unify(ARG3,MkIntegerTerm(sz)) &&
5306 Yap_unify(ARG4,MkIntegerTerm(icls)) &&
5307 Yap_unify(ARG5,MkIntegerTerm(isz));
5308 }
5309
5310 #ifdef DEBUG
5311 static Int
p_predicate_lu_cps(void)5312 p_predicate_lu_cps(void)
5313 {
5314 return Yap_unify(ARG1, MkIntegerTerm(Yap_LiveCps)) &&
5315 Yap_unify(ARG2, MkIntegerTerm(Yap_FreedCps)) &&
5316 Yap_unify(ARG3, MkIntegerTerm(Yap_DirtyCps)) &&
5317 Yap_unify(ARG4, MkIntegerTerm(Yap_NewCps));
5318 }
5319 #endif
5320
5321 static Int
p_program_continuation(void)5322 p_program_continuation(void)
5323 {
5324 PredEntry *pe = EnvPreg((yamop *)((ENV_Parent(ENV))[E_CP]));
5325 if (pe->ModuleOfPred) {
5326 if (!Yap_unify(ARG1,pe->ModuleOfPred))
5327 return FALSE;
5328 } else {
5329 if (!Yap_unify(ARG1,TermProlog))
5330 return FALSE;
5331 }
5332 if (pe->ArityOfPE) {
5333 if (!Yap_unify(ARG2,MkAtomTerm(NameOfFunctor(pe->FunctorOfPred))))
5334 return FALSE;
5335 if (!Yap_unify(ARG3,MkIntegerTerm(ArityOfFunctor(pe->FunctorOfPred))))
5336 return FALSE;
5337 } else {
5338 if (!Yap_unify(ARG2,MkAtomTerm((Atom)pe->FunctorOfPred)))
5339 return FALSE;
5340 if (!Yap_unify(ARG3,MkIntTerm(0)))
5341 return FALSE;
5342 }
5343 return TRUE;
5344 }
5345
5346 static Term
BuildActivePred(PredEntry * ap,CELL * vect)5347 BuildActivePred(PredEntry *ap, CELL *vect)
5348 {
5349 UInt i;
5350
5351 if (!ap->ArityOfPE) {
5352 return MkVarTerm();
5353 }
5354 for (i = 0; i < ap->ArityOfPE; i++) {
5355 Term t = Deref(vect[i]);
5356 if (IsVarTerm(t)) {
5357 CELL *pt = VarOfTerm(t);
5358 /* one stack */
5359 if (pt > H) {
5360 Term nt = MkVarTerm();
5361 Yap_unify(t, nt);
5362 }
5363 }
5364 }
5365 return Yap_MkApplTerm(ap->FunctorOfPred, ap->ArityOfPE, vect);
5366 }
5367
5368 static int
UnifyPredInfo(PredEntry * pe,int start_arg)5369 UnifyPredInfo(PredEntry *pe, int start_arg) {
5370 UInt arity = pe->ArityOfPE;
5371 Term tmod, tname;
5372
5373 if (pe->ModuleOfPred != IDB_MODULE) {
5374 if (pe->ModuleOfPred == PROLOG_MODULE) {
5375 tmod = TermProlog;
5376 } else {
5377 tmod = pe->ModuleOfPred;
5378 }
5379 if (pe->ArityOfPE == 0) {
5380 tname = MkAtomTerm((Atom)pe->FunctorOfPred);
5381 } else {
5382 Functor f = pe->FunctorOfPred;
5383 tname = MkAtomTerm(NameOfFunctor(f));
5384 }
5385 } else {
5386 tmod = pe->ModuleOfPred;
5387 if (pe->PredFlags & NumberDBPredFlag) {
5388 tname = MkIntegerTerm(pe->src.IndxId);
5389 } else if (pe->PredFlags & AtomDBPredFlag) {
5390 tname = MkAtomTerm((Atom)pe->FunctorOfPred);
5391 } else {
5392 Functor f = pe->FunctorOfPred;
5393 tname = MkAtomTerm(NameOfFunctor(f));
5394 }
5395 }
5396
5397 return Yap_unify(XREGS[start_arg], tmod) &&
5398 Yap_unify(XREGS[start_arg+1],tname) &&
5399 Yap_unify(XREGS[start_arg+2],MkIntegerTerm(arity));
5400 }
5401
5402
5403 static Int
ClauseId(yamop * ipc,PredEntry * pe)5404 ClauseId(yamop *ipc, PredEntry *pe)
5405 {
5406 if (!ipc)
5407 return 0;
5408 return find_code_in_clause(pe, ipc, NULL, NULL);
5409 }
5410
5411 static Int
p_env_info(void)5412 p_env_info(void)
5413 {
5414 PredEntry *pe;
5415 CELL *env = LCL0-IntegerOfTerm(Deref(ARG1));
5416 yamop *env_cp;
5417 Term env_b, taddr;
5418
5419 if (!env)
5420 return FALSE;
5421 env_b = MkIntegerTerm((Int)(LCL0-(CELL *)env[E_CB]));
5422 env_cp = (yamop *)env[E_CP];
5423
5424 pe = PREVOP(env_cp,Osbpp)->u.Osbpp.p0;
5425 taddr = MkIntegerTerm((Int)env);
5426 return Yap_unify(ARG3,MkIntegerTerm((Int)env_cp)) &&
5427 Yap_unify(ARG2, taddr) &&
5428 Yap_unify(ARG4, env_b);
5429 }
5430
5431 static Int
p_cpc_info(void)5432 p_cpc_info(void)
5433 {
5434 PredEntry *pe;
5435 yamop *ipc = (yamop *)IntegerOfTerm(Deref(ARG1));
5436
5437 pe = PREVOP(ipc,Osbpp)->u.Osbpp.p0;
5438 return UnifyPredInfo(pe, 2) &&
5439 Yap_unify(ARG5,MkIntegerTerm(ClauseId(ipc,pe)));
5440 }
5441
5442 static Int
p_choicepoint_info(void)5443 p_choicepoint_info(void)
5444 {
5445 choiceptr cptr = (choiceptr)(LCL0-IntegerOfTerm(Deref(ARG1)));
5446 PredEntry *pe = NULL;
5447 int go_on = TRUE;
5448 yamop *ipc = cptr->cp_ap;
5449 yamop *ncl = NULL;
5450 Term t = TermNil, taddr;
5451
5452 taddr = MkIntegerTerm((Int)cptr);
5453 while (go_on) {
5454 op_numbers opnum = Yap_op_from_opcode(ipc->opc);
5455 go_on = FALSE;
5456 switch (opnum) {
5457 #ifdef TABLING
5458 case _table_load_answer:
5459 #ifdef LOW_LEVEL_TRACER
5460 pe = LOAD_CP(cptr)->cp_pred_entry;
5461 #else
5462 pe = UndefCode;
5463 #endif
5464 t = MkVarTerm();
5465 break;
5466 case _table_try_answer:
5467 case _table_retry_me:
5468 case _table_trust_me:
5469 case _table_retry:
5470 case _table_trust:
5471 case _table_completion:
5472 #ifdef LOW_LEVEL_TRACER
5473 #ifdef DETERMINISTIC_TABLING
5474 if (IS_DET_GEN_CP(cptr)) {
5475 pe = DET_GEN_CP(cptr)->cp_pred_entry;
5476 t = MkVarTerm();
5477 } else
5478 #endif /* DETERMINISTIC_TABLING */
5479 {
5480 pe = GEN_CP(cptr)->cp_pred_entry;
5481 t = BuildActivePred(pe, (CELL *)(GEN_CP(B) + 1));
5482 }
5483 #else
5484 pe = UndefCode;
5485 t = MkVarTerm();
5486 #endif
5487 break;
5488 case _table_answer_resolution:
5489 #ifdef LOW_LEVEL_TRACER
5490 pe = CONS_CP(cptr)->cp_pred_entry;
5491 #else
5492 pe = UndefCode;
5493 #endif
5494 t = MkVarTerm();
5495 break;
5496 case _trie_trust_var:
5497 case _trie_retry_var:
5498 case _trie_trust_var_in_pair:
5499 case _trie_retry_var_in_pair:
5500 case _trie_trust_val:
5501 case _trie_retry_val:
5502 case _trie_trust_val_in_pair:
5503 case _trie_retry_val_in_pair:
5504 case _trie_trust_atom:
5505 case _trie_retry_atom:
5506 case _trie_trust_atom_in_pair:
5507 case _trie_retry_atom_in_pair:
5508 case _trie_trust_null:
5509 case _trie_retry_null:
5510 case _trie_trust_null_in_pair:
5511 case _trie_retry_null_in_pair:
5512 case _trie_trust_pair:
5513 case _trie_retry_pair:
5514 case _trie_trust_appl:
5515 case _trie_retry_appl:
5516 case _trie_trust_appl_in_pair:
5517 case _trie_retry_appl_in_pair:
5518 case _trie_trust_extension:
5519 case _trie_retry_extension:
5520 case _trie_trust_double:
5521 case _trie_retry_double:
5522 case _trie_trust_longint:
5523 case _trie_retry_longint:
5524 case _trie_trust_gterm:
5525 case _trie_retry_gterm:
5526 pe = UndefCode;
5527 t = MkVarTerm();
5528 break;
5529 #endif /* TABLING */
5530 case _try_logical:
5531 case _retry_logical:
5532 case _trust_logical:
5533 case _count_retry_logical:
5534 case _count_trust_logical:
5535 case _profiled_retry_logical:
5536 case _profiled_trust_logical:
5537 ncl = ipc->u.OtaLl.d->ClCode;
5538 pe = ipc->u.OtaLl.d->ClPred;
5539 t = BuildActivePred(pe, cptr->cp_args);
5540 break;
5541 case _or_else:
5542 pe = ipc->u.Osblp.p0;
5543 ncl = ipc;
5544 t = Yap_MkNewApplTerm(FunctorOr, 2);
5545 break;
5546
5547 case _or_last:
5548 #ifdef YAPOR
5549 pe = ipc->u.Osblp.p0;
5550 #else
5551 pe = ipc->u.p.p;
5552 #endif
5553 ncl = ipc;
5554 t = Yap_MkNewApplTerm(FunctorOr, 2);
5555 break;
5556 case _retry2:
5557 case _retry3:
5558 case _retry4:
5559 pe = NULL;
5560 t = TermNil;
5561 ipc = NEXTOP(ipc,l);
5562 if (!ncl)
5563 ncl = ipc->u.Otapl.d;
5564 go_on = TRUE;
5565 break;
5566 case _jump:
5567 pe = NULL;
5568 t = TermNil;
5569 ipc = ipc->u.l.l;
5570 go_on = TRUE;
5571 break;
5572 case _retry_c:
5573 case _retry_userc:
5574 ncl = NEXTOP(ipc,OtapFs);
5575 pe = ipc->u.OtapFs.p;
5576 t = BuildActivePred(pe, cptr->cp_args);
5577 break;
5578 case _retry_profiled:
5579 case _count_retry:
5580 pe = NULL;
5581 t = TermNil;
5582 ncl = ipc->u.Otapl.d;
5583 ipc = NEXTOP(ipc,p);
5584 go_on = TRUE;
5585 break;
5586 case _retry_me:
5587 case _trust_me:
5588 case _count_retry_me:
5589 case _count_trust_me:
5590 case _profiled_retry_me:
5591 case _profiled_trust_me:
5592 case _retry_and_mark:
5593 case _profiled_retry_and_mark:
5594 case _retry:
5595 case _trust:
5596 if (!ncl)
5597 ncl = ipc->u.Otapl.d;
5598 pe = ipc->u.Otapl.p;
5599 t = BuildActivePred(pe, cptr->cp_args);
5600 break;
5601 case _Nstop:
5602 {
5603 Atom at = AtomLive;
5604 t = MkAtomTerm(at);
5605 pe = RepPredProp(PredPropByAtom(at, CurrentModule));
5606 }
5607 break;
5608 case _Ystop:
5609 default:
5610 return FALSE;
5611 }
5612 }
5613 return UnifyPredInfo(pe, 3) &&
5614 Yap_unify(ARG2, taddr) &&
5615 Yap_unify(ARG6,t) &&
5616 Yap_unify(ARG7,MkIntegerTerm(ClauseId(ncl,pe)));
5617 }
5618
5619 void
Yap_InitCdMgr(void)5620 Yap_InitCdMgr(void)
5621 {
5622 Term cm = CurrentModule;
5623
5624 Yap_InitCPred("$compile_mode", 2, p_compile_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5625 Yap_InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5626 Yap_InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag|HiddenPredFlag);
5627 Yap_InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5628 Yap_InitCPred("$set_spy", 2, p_setspy, SyncPredFlag|HiddenPredFlag);
5629 Yap_InitCPred("$rm_spy", 2, p_rmspy, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5630 /* gc() may happen during compilation, hence these predicates are
5631 now unsafe */
5632 Yap_InitCPred("$compile", 4, p_compile, SyncPredFlag|HiddenPredFlag);
5633 Yap_InitCPred("$compile_dynamic", 5, p_compile_dynamic, SyncPredFlag|HiddenPredFlag);
5634 Yap_InitCPred("$purge_clauses", 2, p_purge_clauses, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5635 Yap_InitCPred("$in_use", 2, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag|HiddenPredFlag);
5636 Yap_InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag|HiddenPredFlag);
5637 Yap_InitCPred("$is_metapredicate", 2, p_is_metapredicate, TestPredFlag | SafePredFlag|HiddenPredFlag);
5638 Yap_InitCPred("$is_expand_goal_or_meta_predicate", 2, p_is_expandgoalormetapredicate, TestPredFlag | SafePredFlag|HiddenPredFlag);
5639 Yap_InitCPred("$is_log_updatable", 2, p_is_log_updatable, TestPredFlag | SafePredFlag|HiddenPredFlag);
5640 Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag|HiddenPredFlag);
5641 Yap_InitCPred("$owner_file", 3, p_owner_file, SafePredFlag|HiddenPredFlag);
5642 Yap_InitCPred("$mk_d", 2, p_mk_d, SafePredFlag|HiddenPredFlag);
5643 Yap_InitCPred("$pred_exists", 2, p_pred_exists, TestPredFlag | SafePredFlag|HiddenPredFlag);
5644 Yap_InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5645 Yap_InitCPred("$undefined", 2, p_undefined, SafePredFlag|TestPredFlag|HiddenPredFlag);
5646 Yap_InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5647 Yap_InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag|HiddenPredFlag);
5648 Yap_InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5649 Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5650 Yap_InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5651 Yap_InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag|HiddenPredFlag);
5652 Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5653 Yap_InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5654 Yap_InitCPred("$profile_reset", 2, p_profile_reset, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5655 Yap_InitCPred("$is_call_counted", 1, p_is_call_counted, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5656 Yap_InitCPred("$call_count_info", 3, p_call_count_info, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5657 Yap_InitCPred("$call_count_set", 6, p_call_count_set, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5658 Yap_InitCPred("$call_count_reset", 0, p_call_count_reset, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5659 Yap_InitCPred("$toggle_static_predicates_in_use", 0, p_toggle_static_predicates_in_use, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5660 Yap_InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag|HiddenPredFlag);
5661 Yap_InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag|HiddenPredFlag);
5662 Yap_InitCPred("$system_predicate", 2, p_system_pred, SafePredFlag|HiddenPredFlag);
5663 Yap_InitCPred("$all_system_predicate", 3, p_all_system_pred, SafePredFlag|HiddenPredFlag);
5664 Yap_InitCPred("$hide_predicate", 2, p_hide_predicate, SafePredFlag|HiddenPredFlag);
5665 Yap_InitCPred("$hidden_predicate", 2, p_hidden_predicate, SafePredFlag|HiddenPredFlag);
5666 Yap_InitCPred("$pred_for_code", 5, p_pred_for_code, SyncPredFlag|HiddenPredFlag);
5667 Yap_InitCPred("$current_stack", 1, p_current_stack, SyncPredFlag|HiddenPredFlag);
5668 Yap_InitCPred("$log_update_clause", 4, p_log_update_clause, SyncPredFlag|HiddenPredFlag);
5669 Yap_InitCPred("$continue_log_update_clause", 5, p_continue_log_update_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5670 Yap_InitCPred("$log_update_clause_erase", 4, p_log_update_clause_erase, SyncPredFlag|HiddenPredFlag);
5671 Yap_InitCPred("$continue_log_update_clause_erase", 5, p_continue_log_update_clause_erase, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5672 Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag|HiddenPredFlag);
5673 Yap_InitCPred("$continue_static_clause", 5, p_continue_static_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5674 Yap_InitCPred("$static_pred_statistics", 5, p_static_pred_statistics, SyncPredFlag|HiddenPredFlag);
5675 Yap_InitCPred("$p_nth_clause", 4, p_nth_clause, SyncPredFlag|HiddenPredFlag);
5676 Yap_InitCPred("$program_continuation", 3, p_program_continuation, SafePredFlag|SyncPredFlag|HiddenPredFlag);
5677 CurrentModule = HACKS_MODULE;
5678 Yap_InitCPred("current_choicepoints", 1, p_all_choicepoints, HiddenPredFlag);
5679 Yap_InitCPred("current_continuations", 1, p_all_envs, HiddenPredFlag);
5680 Yap_InitCPred("choicepoint", 7, p_choicepoint_info, HiddenPredFlag);
5681 Yap_InitCPred("continuation", 4, p_env_info, HiddenPredFlag);
5682 Yap_InitCPred("cp_to_predicate", 5, p_cpc_info, HiddenPredFlag);
5683 CurrentModule = cm;
5684 Yap_InitCPred("$predicate_erased_statistics", 5, p_predicate_erased_statistics, SyncPredFlag);
5685 #ifdef DEBUG
5686 Yap_InitCPred("$predicate_live_cps", 4, p_predicate_lu_cps, 0L);
5687 #endif
5688 }
5689
5690