5703 lines
150 KiB
C
5703 lines
150 KiB
C
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: cdmgr.c *
|
|
* comments: Code manager *
|
|
* *
|
|
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ *
|
|
* $Log: not supported by cvs2svn $
|
|
* Revision 1.230 2008/06/02 17:20:28 vsc
|
|
* fix abolish bug
|
|
*
|
|
* Revision 1.229 2008/05/28 17:18:35 vsc
|
|
* thread fixes
|
|
*
|
|
* Revision 1.228 2008/04/28 23:02:32 vsc
|
|
* fix bug in current_predicate/2
|
|
* fix bug in c_interface.
|
|
*
|
|
* Revision 1.227 2008/04/11 16:30:27 ricroc
|
|
* *** empty log message ***
|
|
*
|
|
* Revision 1.226 2008/04/01 22:28:41 vsc
|
|
* put YAPOR back to life.
|
|
*
|
|
* Revision 1.225 2008/04/01 08:42:45 vsc
|
|
* fix restore and small VISTA thingies
|
|
*
|
|
* Revision 1.224 2008/03/31 22:56:21 vsc
|
|
* more fixes
|
|
*
|
|
* Revision 1.223 2008/03/25 16:45:53 vsc
|
|
* make or-parallelism compile again
|
|
*
|
|
* Revision 1.222 2008/03/24 23:48:47 vsc
|
|
* fix maximum number of threads open error
|
|
*
|
|
* Revision 1.221 2008/03/22 23:35:00 vsc
|
|
* fix bug in all_calls
|
|
*
|
|
* Revision 1.220 2008/03/17 18:31:16 vsc
|
|
* fix breakage in module system
|
|
* disable stack writing in error for now
|
|
*
|
|
* Revision 1.219 2008/02/22 15:08:33 vsc
|
|
* Big update to support more SICStus/SWI like message handling
|
|
* fix YAPSHAREDIR
|
|
* fix yap.tex (Bernd)
|
|
*
|
|
* Revision 1.218 2008/01/23 17:57:44 vsc
|
|
* valgrind it!
|
|
* enable atom garbage collection.
|
|
*
|
|
* Revision 1.217 2007/12/26 19:50:40 vsc
|
|
* new version of clp(fd)
|
|
* fix deadlock with empty args facts in clause/2.
|
|
*
|
|
* Revision 1.216 2007/12/23 22:48:44 vsc
|
|
* recover stack space
|
|
*
|
|
* Revision 1.215 2007/12/18 17:46:58 vsc
|
|
* purge_clauses does not need to do anything if there are no clauses
|
|
* fix gprof bugs.
|
|
*
|
|
* Revision 1.214 2007/11/28 23:52:14 vsc
|
|
* junction tree algorithm
|
|
*
|
|
* Revision 1.213 2007/11/26 23:43:07 vsc
|
|
* fixes to support threads and assert correctly, even if inefficiently.
|
|
*
|
|
* Revision 1.212 2007/11/16 14:58:40 vsc
|
|
* implement sophisticated operations with matrices.
|
|
*
|
|
* Revision 1.211 2007/11/08 09:53:01 vsc
|
|
* YAP would always say the system has tabling!
|
|
*
|
|
* Revision 1.210 2007/11/07 09:25:27 vsc
|
|
* speedup meta-calls
|
|
*
|
|
* Revision 1.209 2007/11/06 17:02:11 vsc
|
|
* compile ground terms away.
|
|
*
|
|
* Revision 1.208 2007/11/01 10:01:35 vsc
|
|
* fix uninitalised lock and reconsult test.
|
|
*
|
|
* Revision 1.207 2007/10/29 22:48:54 vsc
|
|
* small fixes
|
|
*
|
|
* Revision 1.206 2007/04/10 22:13:20 vsc
|
|
* fix max modules limitation
|
|
*
|
|
* Revision 1.205 2007/03/26 15:18:43 vsc
|
|
* debugging and clause/3 over tabled predicates would kill YAP.
|
|
*
|
|
* Revision 1.204 2007/01/25 22:11:55 vsc
|
|
* all/3 should fail on no solutions.
|
|
* get rid of annoying gcc complaints.
|
|
*
|
|
* Revision 1.203 2007/01/24 10:01:38 vsc
|
|
* fix matrix mess
|
|
*
|
|
* Revision 1.202 2006/12/27 01:32:37 vsc
|
|
* diverse fixes
|
|
*
|
|
* Revision 1.201 2006/12/13 16:10:14 vsc
|
|
* several debugger and CLP(BN) improvements.
|
|
*
|
|
* Revision 1.200 2006/11/27 17:42:02 vsc
|
|
* support for UNICODE, and other bug fixes.
|
|
*
|
|
* Revision 1.199 2006/11/15 00:13:36 vsc
|
|
* fixes for indexing code.
|
|
*
|
|
* Revision 1.198 2006/11/14 11:42:25 vsc
|
|
* fix bug in growstack
|
|
*
|
|
* Revision 1.197 2006/11/06 18:35:03 vsc
|
|
* 1estranha
|
|
*
|
|
* Revision 1.196 2006/10/16 17:12:48 vsc
|
|
* fixes for threaded version.
|
|
*
|
|
* Revision 1.195 2006/10/11 17:24:36 vsc
|
|
* make sure we only follow pointers *before* we removed the respective code block,
|
|
* ie don't kill the child before checking pointers from parent!
|
|
*
|
|
* Revision 1.194 2006/10/11 15:08:03 vsc
|
|
* fix bb entries
|
|
* comment development code for timestamp overflow.
|
|
*
|
|
* Revision 1.193 2006/10/11 14:53:57 vsc
|
|
* fix memory leak
|
|
* fix overflow handling
|
|
* VS: ----------------------------------------------------------------------
|
|
*
|
|
* Revision 1.192 2006/10/10 14:08:16 vsc
|
|
* small fixes on threaded implementation.
|
|
*
|
|
* Revision 1.191 2006/09/20 20:03:51 vsc
|
|
* improve indexing on floats
|
|
* fix sending large lists to DB
|
|
*
|
|
* Revision 1.190 2006/08/07 18:51:44 vsc
|
|
* fix garbage collector not to try to garbage collect when we ask for large
|
|
* chunks of stack in a single go.
|
|
*
|
|
* Revision 1.189 2006/05/24 02:35:39 vsc
|
|
* make chr work and other minor fixes.
|
|
*
|
|
* Revision 1.188 2006/05/18 16:33:04 vsc
|
|
* fix info reported by memory manager under DL_MALLOC and SYSTEM_MALLOC
|
|
*
|
|
* Revision 1.187 2006/04/29 01:15:18 vsc
|
|
* fix expand_consult patch
|
|
*
|
|
* Revision 1.186 2006/04/28 17:53:44 vsc
|
|
* fix the expand_consult patch
|
|
*
|
|
* Revision 1.185 2006/04/28 13:23:22 vsc
|
|
* fix number of overflow bugs affecting threaded version
|
|
* make current_op faster.
|
|
*
|
|
* Revision 1.184 2006/04/27 14:11:57 rslopes
|
|
* *** empty log message ***
|
|
*
|
|
* Revision 1.183 2006/03/29 16:00:10 vsc
|
|
* make tabling compile
|
|
*
|
|
* Revision 1.182 2006/03/24 16:26:26 vsc
|
|
* code review
|
|
*
|
|
* Revision 1.181 2006/03/22 20:07:28 vsc
|
|
* take better care of zombies
|
|
*
|
|
* Revision 1.180 2006/03/22 16:14:20 vsc
|
|
* don't be too eager at throwing indexing code for static predicates away.
|
|
*
|
|
* Revision 1.179 2006/03/21 17:11:39 vsc
|
|
* prevent breakage
|
|
*
|
|
* Revision 1.178 2006/03/20 19:51:43 vsc
|
|
* fix indexing and tabling bugs
|
|
*
|
|
* Revision 1.177 2006/03/06 14:04:56 vsc
|
|
* fixes to garbage collector
|
|
* fixes to debugger
|
|
*
|
|
* Revision 1.176 2006/02/01 13:28:56 vsc
|
|
* bignum support fixes
|
|
*
|
|
* Revision 1.175 2006/01/08 03:12:00 vsc
|
|
* fix small bug in attvar handling.
|
|
*
|
|
* Revision 1.174 2005/12/23 00:20:13 vsc
|
|
* updates to gprof
|
|
* support for __POWER__
|
|
* Try to saveregs before longjmp.
|
|
*
|
|
* Revision 1.173 2005/12/17 03:25:39 vsc
|
|
* major changes to support online event-based profiling
|
|
* improve error discovery and restart on scanner.
|
|
*
|
|
* Revision 1.172 2005/11/23 03:01:33 vsc
|
|
* fix several bugs in save/restore.b
|
|
*
|
|
* Revision 1.171 2005/10/29 01:28:37 vsc
|
|
* make undefined more ISO compatible.
|
|
*
|
|
* Revision 1.170 2005/10/18 17:04:43 vsc
|
|
* 5.1:
|
|
* - improvements to GC
|
|
* 2 generations
|
|
* generic speedups
|
|
* - new scheme for attvars
|
|
* - hProlog like interface also supported
|
|
* - SWI compatibility layer
|
|
* - extra predicates
|
|
* - global variables
|
|
* - moved to Prolog module
|
|
* - CLP(R) by Leslie De Koninck, Tom Schrijvers, Cristian Holzbaur, Bart
|
|
* Demoen and Jan Wielemacker
|
|
* - load_files/2
|
|
*
|
|
* from 5.0.1
|
|
*
|
|
* - WIN32 missing include files (untested)
|
|
* - -L trouble (my thanks to Takeyuchi Shiramoto-san)!
|
|
* - debugging of backtrable user-C preds would core dump.
|
|
* - redeclaring a C-predicate as Prolog core dumps.
|
|
* - badly protected YapInterface.h.
|
|
* - break/0 was failing at exit.
|
|
* - YAP_cut_fail and YAP_cut_succeed were different from manual.
|
|
* - tracing through data-bases could core dump.
|
|
* - cut could break on very large computations.
|
|
* - first pass at BigNum issues (reported by Roberto).
|
|
* - debugger could get go awol after fail port.
|
|
* - weird message on wrong debugger option.
|
|
*
|
|
* Revision 1.169 2005/10/15 02:05:57 vsc
|
|
* fix for trying to add clauses to a C pred.
|
|
*
|
|
* Revision 1.168 2005/08/05 14:55:02 vsc
|
|
* first steps to allow mavars with tabling
|
|
* fix trailing for tabling with multiple get_cons
|
|
*
|
|
* Revision 1.167 2005/08/02 03:09:49 vsc
|
|
* fix debugger to do well nonsource predicates.
|
|
*
|
|
* Revision 1.166 2005/08/01 15:40:37 ricroc
|
|
* TABLING NEW: better support for incomplete tabling
|
|
*
|
|
* Revision 1.165 2005/07/06 19:33:52 ricroc
|
|
* TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure.
|
|
*
|
|
* Revision 1.164 2005/07/06 15:10:03 vsc
|
|
* improvements to compiler: merged instructions and fixes for ->
|
|
*
|
|
* Revision 1.163 2005/06/08 00:35:27 vsc
|
|
* fix silly calls such as 0.15 ( bug reported by Jude Shavlik)
|
|
*
|
|
* Revision 1.162 2005/06/04 07:27:33 ricroc
|
|
* long int support for tabling
|
|
*
|
|
* Revision 1.161 2005/06/03 08:26:32 ricroc
|
|
* float support for tabling
|
|
*
|
|
* Revision 1.160 2005/06/01 14:02:47 vsc
|
|
* get_rid of try_me?, retry_me? and trust_me? instructions: they are not
|
|
* significantly used nowadays.
|
|
*
|
|
* Revision 1.159 2005/05/31 19:42:27 vsc
|
|
* insert some more slack for indices in LU
|
|
* Use doubly linked list for LU indices so that updating is less cumbersome.
|
|
*
|
|
* Revision 1.158 2005/05/31 00:30:23 ricroc
|
|
* remove abort_yapor function
|
|
*
|
|
* Revision 1.157 2005/05/12 03:36:32 vsc
|
|
* debugger was making predicates meta instead of testing
|
|
* fix handling of dbrefs in facts and in subarguments.
|
|
*
|
|
* Revision 1.156 2005/04/20 04:02:15 vsc
|
|
* fix a few variable warnings
|
|
* fix erase clause to pass a pointer to clause, not code
|
|
* get rid of Yap4.4 code in Yap_EraseStaticClause
|
|
*
|
|
* Revision 1.155 2005/04/10 04:01:10 vsc
|
|
* bug fixes, I hope!
|
|
*
|
|
* Revision 1.154 2005/03/04 20:30:11 ricroc
|
|
* bug fixes for YapTab support
|
|
*
|
|
* Revision 1.153 2005/02/25 03:39:44 vsc
|
|
* fix fixes to undefp
|
|
* fix bug where clause mistook cp for ap
|
|
*
|
|
* Revision 1.152 2005/02/08 18:04:57 vsc
|
|
* library_directory may not be deterministic (usually it isn't).
|
|
*
|
|
* Revision 1.151 2005/02/08 04:05:23 vsc
|
|
* fix mess with add clause
|
|
* improves on sigsegv handling
|
|
*
|
|
* Revision 1.150 2005/01/28 23:14:34 vsc
|
|
* move to Yap-4.5.7
|
|
* Fix clause size
|
|
*
|
|
* Revision 1.149 2005/01/05 05:35:01 vsc
|
|
* get rid of debugging stub.
|
|
*
|
|
* Revision 1.148 2005/01/04 02:50:21 vsc
|
|
* - allow MegaClauses with blobs
|
|
* - change Diffs to be thread specific
|
|
* - include Christian's updates
|
|
*
|
|
* Revision 1.147 2004/12/28 22:20:35 vsc
|
|
* some extra bug fixes for trail overflows: some cannot be recovered that easily,
|
|
* some can.
|
|
*
|
|
* Revision 1.146 2004/12/20 21:44:57 vsc
|
|
* more fixes to CLPBN
|
|
* fix some Yap overflows.
|
|
*
|
|
* Revision 1.145 2004/12/16 05:57:23 vsc
|
|
* fix overflows
|
|
*
|
|
* Revision 1.144 2004/12/08 00:10:48 vsc
|
|
* more grow fixes
|
|
*
|
|
* Revision 1.143 2004/12/05 05:01:23 vsc
|
|
* try to reduce overheads when running with goal expansion enabled.
|
|
* CLPBN fixes
|
|
* Handle overflows when allocating big clauses properly.
|
|
*
|
|
* Revision 1.142 2004/11/18 22:32:31 vsc
|
|
* fix situation where we might assume nonextsing double initialisation of C predicates (use
|
|
* Hidden Pred Flag).
|
|
* $host_type was double initialised.
|
|
*
|
|
* Revision 1.141 2004/11/04 18:22:31 vsc
|
|
* don't ever use memory that has been freed (that was done by LU).
|
|
* generic fixes for WIN32 libraries
|
|
*
|
|
* Revision 1.140 2004/10/31 02:18:03 vsc
|
|
* fix bug in handling Yap heap overflow while adding new clause.
|
|
*
|
|
* Revision 1.139 2004/10/28 20:12:21 vsc
|
|
* Use Doug Lea's malloc as an alternative to YAP's standard malloc
|
|
* don't use TR directly in scanner/parser, this avoids trouble with ^C while
|
|
* consulting large files.
|
|
* pass gcc -mno-cygwin to library compilation in cygwin environment (cygwin should
|
|
* compile out of the box now).
|
|
*
|
|
* Revision 1.138 2004/10/26 20:15:51 vsc
|
|
* More bug fixes for overflow handling
|
|
*
|
|
* Revision 1.137 2004/10/22 16:53:19 vsc
|
|
* bug fixes
|
|
*
|
|
* Revision 1.136 2004/10/06 16:55:46 vsc
|
|
* change configure to support big mem configs
|
|
* get rid of extra globals
|
|
* fix trouble with multifile preds
|
|
*
|
|
* Revision 1.135 2004/09/30 21:37:40 vsc
|
|
* fixes for thread support
|
|
*
|
|
* Revision 1.134 2004/09/30 19:51:53 vsc
|
|
* fix overflow from within clause/2
|
|
*
|
|
* Revision 1.133 2004/09/27 20:45:02 vsc
|
|
* Mega clauses
|
|
* Fixes to sizeof(expand_clauses) which was being overestimated
|
|
* Fixes to profiling+indexing
|
|
* Fixes to reallocation of memory after restoring
|
|
* Make sure all clauses, even for C, end in _Ystop
|
|
* Don't reuse space for Streams
|
|
* Fix Stream_F on StreaNo+1
|
|
*
|
|
* Revision 1.132 2004/09/17 19:34:51 vsc
|
|
* simplify frozen/2
|
|
*
|
|
* Revision 1.131 2004/09/08 17:56:45 vsc
|
|
* source: a(X) :- true is a fact!
|
|
* fix use of value after possible overflow in IPred
|
|
*
|
|
* Revision 1.130 2004/09/07 16:48:04 vsc
|
|
* fix bug in unwinding trail at amiops.h
|
|
*
|
|
* Revision 1.129 2004/09/07 16:25:22 vsc
|
|
* memory management bug fixes
|
|
*
|
|
* Revision 1.128 2004/09/03 03:11:07 vsc
|
|
* memory management fixes
|
|
*
|
|
* Revision 1.127 2004/08/16 21:02:04 vsc
|
|
* more fixes for !
|
|
*
|
|
* Revision 1.126 2004/07/22 21:32:20 vsc
|
|
* debugger fixes
|
|
* initial support for JPL
|
|
* bad calls to garbage collector and gc
|
|
* debugger fixes
|
|
*
|
|
* Revision 1.125 2004/06/29 19:04:41 vsc
|
|
* fix multithreaded version
|
|
* include new version of Ricardo's profiler
|
|
* new predicat atomic_concat
|
|
* allow multithreaded-debugging
|
|
* small fixes
|
|
*
|
|
* Revision 1.124 2004/06/05 03:36:59 vsc
|
|
* coroutining is now a part of attvars.
|
|
* some more fixes.
|
|
*
|
|
* Revision 1.123 2004/05/17 21:42:09 vsc
|
|
* misc fixes
|
|
*
|
|
* Revision 1.122 2004/05/13 21:36:45 vsc
|
|
* get rid of pesky debugging prints
|
|
*
|
|
* Revision 1.121 2004/05/13 20:54:57 vsc
|
|
* debugger fixes
|
|
* make sure we always go back to current module, even during initizlization.
|
|
*
|
|
* Revision 1.120 2004/04/27 16:21:16 vsc
|
|
* stupid bug
|
|
*
|
|
* Revision 1.119 2004/04/27 15:03:43 vsc
|
|
* more fixes for expand_clauses
|
|
*
|
|
* Revision 1.118 2004/04/14 19:10:23 vsc
|
|
* expand_clauses: keep a list of clauses to expand
|
|
* fix new trail scheme for multi-assignment variables
|
|
*
|
|
* Revision 1.117 2004/04/07 22:04:03 vsc
|
|
* fix memory leaks
|
|
*
|
|
* Revision 1.116 2004/03/31 01:03:09 vsc
|
|
* support expand group of clauses
|
|
*
|
|
* Revision 1.115 2004/03/19 11:35:42 vsc
|
|
* trim_trail for default machine
|
|
* be more aggressive about try-retry-trust chains.
|
|
* - handle cases where block starts with a wait
|
|
* - don't use _killed instructions, just let the thing rot by itself.
|
|
*
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
|
|
#endif
|
|
|
|
#include "Yap.h"
|
|
#include "clause.h"
|
|
#include "yapio.h"
|
|
#include "eval.h"
|
|
#include "tracer.h"
|
|
#ifdef YAPOR
|
|
#include "or.macros.h"
|
|
#endif /* YAPOR */
|
|
#ifdef TABLING
|
|
#include "tab.macros.h"
|
|
#endif /* TABLING */
|
|
#if HAVE_STRING_H
|
|
#include <string.h>
|
|
#endif
|
|
|
|
|
|
STATIC_PROTO(void retract_all, (PredEntry *, int));
|
|
STATIC_PROTO(void add_first_static, (PredEntry *, yamop *, int));
|
|
STATIC_PROTO(void add_first_dynamic, (PredEntry *, yamop *, int));
|
|
STATIC_PROTO(void asserta_stat_clause, (PredEntry *, yamop *, int));
|
|
STATIC_PROTO(void asserta_dynam_clause, (PredEntry *, yamop *));
|
|
STATIC_PROTO(void assertz_stat_clause, (PredEntry *, yamop *, int));
|
|
STATIC_PROTO(void assertz_dynam_clause, (PredEntry *, yamop *));
|
|
STATIC_PROTO(void expand_consult, (void));
|
|
STATIC_PROTO(int not_was_reconsulted, (PredEntry *, Term, int));
|
|
STATIC_PROTO(int RemoveIndexation, (PredEntry *));
|
|
#if EMACS
|
|
STATIC_PROTO(int last_clause_number, (PredEntry *));
|
|
#endif
|
|
STATIC_PROTO(int static_in_use, (PredEntry *, int));
|
|
#if !defined(YAPOR) && !defined(THREADS)
|
|
STATIC_PROTO(Int search_for_static_predicate_in_use, (PredEntry *, int));
|
|
STATIC_PROTO(void mark_pred, (int, PredEntry *));
|
|
STATIC_PROTO(void do_toggle_static_predicates_in_use, (int));
|
|
#endif
|
|
STATIC_PROTO(Int p_number_of_clauses, (void));
|
|
STATIC_PROTO(Int p_compile, (void));
|
|
STATIC_PROTO(Int p_compile_dynamic, (void));
|
|
STATIC_PROTO(Int p_purge_clauses, (void));
|
|
STATIC_PROTO(Int p_setspy, (void));
|
|
STATIC_PROTO(Int p_rmspy, (void));
|
|
STATIC_PROTO(Int p_startconsult, (void));
|
|
STATIC_PROTO(Int p_showconslultlev, (void));
|
|
STATIC_PROTO(Int p_endconsult, (void));
|
|
STATIC_PROTO(Int p_undefined, (void));
|
|
STATIC_PROTO(Int p_in_use, (void));
|
|
STATIC_PROTO(Int p_new_multifile, (void));
|
|
STATIC_PROTO(Int p_is_multifile, (void));
|
|
STATIC_PROTO(Int p_optimizer_on, (void));
|
|
STATIC_PROTO(Int p_optimizer_off, (void));
|
|
STATIC_PROTO(Int p_in_this_f_before, (void));
|
|
STATIC_PROTO(Int p_first_cl_in_f, (void));
|
|
STATIC_PROTO(Int p_is_dynamic, (void));
|
|
STATIC_PROTO(Int p_kill_dynamic, (void));
|
|
STATIC_PROTO(Int p_compile_mode, (void));
|
|
STATIC_PROTO(Int p_is_profiled, (void));
|
|
STATIC_PROTO(Int p_profile_info, (void));
|
|
STATIC_PROTO(Int p_profile_reset, (void));
|
|
STATIC_PROTO(Int p_is_call_counted, (void));
|
|
STATIC_PROTO(Int p_call_count_info, (void));
|
|
STATIC_PROTO(Int p_call_count_set, (void));
|
|
STATIC_PROTO(Int p_call_count_reset, (void));
|
|
STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void));
|
|
STATIC_PROTO(Atom YapConsultingFile, (void));
|
|
STATIC_PROTO(Int PredForCode,(yamop *, Atom *, UInt *, Term *));
|
|
STATIC_PROTO(void kill_first_log_iblock,(LogUpdIndex *, LogUpdIndex *, PredEntry *));
|
|
STATIC_PROTO(LogUpdIndex *find_owner_log_index,(LogUpdIndex *, yamop *));
|
|
STATIC_PROTO(StaticIndex *find_owner_static_index,(StaticIndex *, yamop *));
|
|
|
|
#define PredArity(p) (p->ArityOfPE)
|
|
#define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G)
|
|
#define NEXTOP(V,TYPE) ((yamop *)(&((V)->u.TYPE.next)))
|
|
|
|
#define IN_BLOCK(P,B,SZ) ((CODEADDR)(P) >= (CODEADDR)(B) && \
|
|
(CODEADDR)(P) < (CODEADDR)(B)+(SZ))
|
|
|
|
static PredEntry *
|
|
PredForChoicePt(yamop *p_code) {
|
|
while (TRUE) {
|
|
op_numbers opnum;
|
|
if (!p_code)
|
|
return NULL;
|
|
opnum = Yap_op_from_opcode(p_code->opc);
|
|
switch(opnum) {
|
|
case _Nstop:
|
|
return NULL;
|
|
case _jump:
|
|
p_code = p_code->u.l.l;
|
|
break;
|
|
case _retry_me:
|
|
case _trust_me:
|
|
return p_code->u.Otapl.p;
|
|
case _try_logical:
|
|
case _retry_logical:
|
|
case _trust_logical:
|
|
case _count_retry_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_retry_logical:
|
|
case _profiled_trust_logical:
|
|
return p_code->u.OtaLl.d->ClPred;
|
|
#ifdef TABLING
|
|
case _trie_trust_null:
|
|
case _trie_retry_null:
|
|
case _trie_trust_null_in_new_pair:
|
|
case _trie_retry_null_in_new_pair:
|
|
case _trie_trust_var:
|
|
case _trie_retry_var:
|
|
case _trie_trust_var_in_new_pair:
|
|
case _trie_retry_var_in_new_pair:
|
|
case _trie_trust_val:
|
|
case _trie_retry_val:
|
|
case _trie_trust_val_in_new_pair:
|
|
case _trie_retry_val_in_new_pair:
|
|
case _trie_trust_atom:
|
|
case _trie_retry_atom:
|
|
case _trie_trust_atom_in_new_pair:
|
|
case _trie_retry_atom_in_new_pair:
|
|
case _trie_trust_pair:
|
|
case _trie_retry_pair:
|
|
case _trie_trust_struct:
|
|
case _trie_retry_struct:
|
|
case _trie_trust_struct_in_new_pair:
|
|
case _trie_retry_struct_in_new_pair:
|
|
case _trie_trust_extension:
|
|
case _trie_retry_extension:
|
|
case _trie_trust_float:
|
|
case _trie_retry_float:
|
|
case _trie_trust_long:
|
|
case _trie_retry_long:
|
|
return NULL;
|
|
case _table_load_answer:
|
|
case _table_try_answer:
|
|
case _table_answer_resolution:
|
|
case _table_completion:
|
|
return NULL; /* ricroc: is this OK? */
|
|
/* compile error --> return ENV_ToP(gc_B->cp_cp); */
|
|
#endif /* TABLING */
|
|
case _or_else:
|
|
if (p_code == p_code->u.Osblp.l) {
|
|
/* repeat */
|
|
Atom at = AtomRepeatSpace;
|
|
return RepPredProp(PredPropByAtom(at, PROLOG_MODULE));
|
|
} else {
|
|
return p_code->u.Osblp.p0;
|
|
}
|
|
break;
|
|
case _or_last:
|
|
#ifdef YAPOR
|
|
return p_code->u.Osblp.p0;
|
|
#else
|
|
return p_code->u.p.p;
|
|
#endif /* YAPOR */
|
|
break;
|
|
case _count_retry_me:
|
|
case _retry_profiled:
|
|
case _retry2:
|
|
case _retry3:
|
|
case _retry4:
|
|
p_code = NEXTOP(p_code,l);
|
|
break;
|
|
default:
|
|
return p_code->u.Otapl.p;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
PredEntry *
|
|
Yap_PredForChoicePt(choiceptr cp) {
|
|
if (cp == NULL)
|
|
return NULL;
|
|
return PredForChoicePt(cp->cp_ap);
|
|
}
|
|
|
|
static void
|
|
InitConsultStack(void)
|
|
{
|
|
ConsultLow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
|
|
if (ConsultLow == NULL) {
|
|
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
|
|
return;
|
|
}
|
|
ConsultCapacity = InitialConsultCapacity;
|
|
ConsultBase = ConsultSp =
|
|
ConsultLow + ConsultCapacity;
|
|
}
|
|
|
|
void
|
|
Yap_ResetConsultStack(void)
|
|
{
|
|
Yap_FreeCodeSpace((char *)ConsultLow);
|
|
ConsultBase =
|
|
ConsultSp =
|
|
ConsultLow =
|
|
NULL;
|
|
ConsultCapacity = InitialConsultCapacity;
|
|
}
|
|
|
|
|
|
/******************************************************************
|
|
|
|
EXECUTING PROLOG CLAUSES
|
|
|
|
******************************************************************/
|
|
|
|
|
|
static int
|
|
static_in_use(PredEntry *p, int check_everything)
|
|
{
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
return TRUE;
|
|
#else
|
|
CELL pflags = p->PredFlags;
|
|
if (pflags & (DynamicPredFlag|LogUpdatePredFlag)) {
|
|
return FALSE;
|
|
}
|
|
if (STATIC_PREDICATES_MARKED) {
|
|
return (p->PredFlags & InUsePredFlag);
|
|
} else {
|
|
/* This code does not work for YAPOR or THREADS!!!!!!!! */
|
|
return(search_for_static_predicate_in_use(p, check_everything));
|
|
}
|
|
#endif
|
|
}
|
|
|
|
/******************************************************************
|
|
|
|
ADDING AND REMOVE INFO TO A PROCEDURE
|
|
|
|
******************************************************************/
|
|
|
|
|
|
/*
|
|
* we have three kinds of predicates: dynamic DynamicPredFlag
|
|
* static CompiledPredFlag fast FastPredFlag all the
|
|
* database predicates are supported for dynamic predicates only abolish and
|
|
* assertz are supported for static predicates no database predicates are
|
|
* supportted for fast predicates
|
|
*/
|
|
|
|
#define is_dynamic(pe) (pe->PredFlags & DynamicPredFlag)
|
|
#define is_static(pe) (pe->PredFlags & CompiledPredFlag)
|
|
#define is_logupd(pe) (pe->PredFlags & LogUpdatePredFlag)
|
|
#ifdef TABLING
|
|
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
|
|
#endif /* TABLING */
|
|
|
|
|
|
static PredEntry *
|
|
get_pred(Term t, Term tmod, char *pname)
|
|
{
|
|
Term t0 = t;
|
|
|
|
restart:
|
|
if (IsVarTerm(t)) {
|
|
Yap_Error(INSTANTIATION_ERROR, t0, pname);
|
|
return NULL;
|
|
} else if (IsAtomTerm(t)) {
|
|
return RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
|
|
} else if (IsIntegerTerm(t) && tmod == IDB_MODULE) {
|
|
return Yap_FindLUIntKey(IntegerOfTerm(t));
|
|
} else if (IsApplTerm(t)) {
|
|
Functor fun = FunctorOfTerm(t);
|
|
if (IsExtensionFunctor(fun)) {
|
|
Yap_Error(TYPE_ERROR_CALLABLE, t0, pname);
|
|
return NULL;
|
|
}
|
|
if (fun == FunctorModule) {
|
|
Term tmod = ArgOfTerm(1, t);
|
|
if (IsVarTerm(tmod) ) {
|
|
Yap_Error(INSTANTIATION_ERROR, t0, pname);
|
|
return NULL;
|
|
}
|
|
if (!IsAtomTerm(tmod) ) {
|
|
Yap_Error(TYPE_ERROR_ATOM, t0, pname);
|
|
return NULL;
|
|
}
|
|
t = ArgOfTerm(2, t);
|
|
goto restart;
|
|
}
|
|
return RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
|
|
} else
|
|
return NULL;
|
|
}
|
|
|
|
/******************************************************************
|
|
|
|
Mega Clauses
|
|
|
|
******************************************************************/
|
|
|
|
|
|
#define OrArgAdjust(P)
|
|
#define TabEntryAdjust(P)
|
|
#define DoubleInCodeAdjust(D)
|
|
#define IntegerInCodeAdjust(D)
|
|
#define IntegerAdjust(D) (D)
|
|
#define PtoPredAdjust(X) (X)
|
|
#define PtoOpAdjust(X) (X)
|
|
#define PtoLUClauseAdjust(P) (P)
|
|
#define PtoLUIndexAdjust(P) (P)
|
|
#define XAdjust(X) (X)
|
|
#define YAdjust(X) (X)
|
|
#define AtomTermAdjust(X) (X)
|
|
#define CellPtoHeapAdjust(X) (X)
|
|
#define FuncAdjust(X) (X)
|
|
#define CodeAddrAdjust(X) (X)
|
|
#define CodeComposedTermAdjust(X) (X)
|
|
#define ConstantAdjust(X) (X)
|
|
#define ArityAdjust(X) (X)
|
|
#define OpcodeAdjust(X) (X)
|
|
#define ModuleAdjust(X) (X)
|
|
#define ExternalFunctionAdjust(X) (X)
|
|
#define AdjustSwitchTable(X,Y,Z)
|
|
#define rehash(A,B,C)
|
|
static Term BlobTermAdjust(Term t)
|
|
{
|
|
#if TAGS_FAST_OPS
|
|
return t-ClDiff;
|
|
#else
|
|
return t+ClDiff;
|
|
#endif
|
|
}
|
|
|
|
static Term ConstantTermAdjust (Term);
|
|
|
|
static Term
|
|
ConstantTermAdjust (Term t)
|
|
{
|
|
if (IsAtomTerm(t))
|
|
return AtomTermAdjust(t);
|
|
else if (IsIntTerm(t))
|
|
return t;
|
|
else if (IsApplTerm(t))
|
|
return BlobTermAdjust(t);
|
|
else if (IsPairTerm(t))
|
|
return CodeComposedTermAdjust(t);
|
|
else return t;
|
|
}
|
|
|
|
|
|
#include "rclause.h"
|
|
|
|
#ifdef DEBUG
|
|
static UInt total_megaclause, total_released, nof_megaclauses;
|
|
#endif
|
|
|
|
void
|
|
Yap_BuildMegaClause(PredEntry *ap)
|
|
{
|
|
StaticClause *cl;
|
|
UInt sz;
|
|
MegaClause *mcl;
|
|
yamop *ptr;
|
|
UInt required;
|
|
UInt has_blobs = 0;
|
|
|
|
if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|MegaClausePredFlag
|
|
#ifdef TABLING
|
|
|TabledPredFlag
|
|
#endif /* TABLING */
|
|
|UDIPredFlag) ||
|
|
ap->cs.p_code.FirstClause == NULL ||
|
|
ap->cs.p_code.NOfClauses < 16) {
|
|
return;
|
|
}
|
|
cl =
|
|
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
|
|
sz = cl->ClSize;
|
|
while (TRUE) {
|
|
if (!(cl->ClFlags & FactMask)) return; /* no mega clause, sorry */
|
|
if (cl->ClSize != sz) return; /* no mega clause, sorry */
|
|
if (cl->ClCode == ap->cs.p_code.LastClause)
|
|
break;
|
|
has_blobs |= (cl->ClFlags & HasBlobsMask);
|
|
cl = cl->ClNext;
|
|
}
|
|
/* ok, we got the chance for a mega clause */
|
|
if (has_blobs) {
|
|
sz -= sizeof(StaticClause);
|
|
} else {
|
|
sz -= (UInt)NEXTOP((yamop *)NULL,p) + sizeof(StaticClause);
|
|
}
|
|
required = sz*ap->cs.p_code.NOfClauses+sizeof(MegaClause)+(UInt)NEXTOP((yamop *)NULL,l);
|
|
#ifdef DEBUG
|
|
total_megaclause += required;
|
|
total_released += ap->cs.p_code.NOfClauses*(sz+sizeof(StaticClause));
|
|
nof_megaclauses++;
|
|
#endif
|
|
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
|
|
if (!Yap_growheap(FALSE, required, NULL)) {
|
|
/* just fail, the system will keep on going */
|
|
return;
|
|
}
|
|
}
|
|
Yap_ClauseSpace += required;
|
|
/* cool, it's our turn to do the conversion */
|
|
mcl->ClFlags = MegaMask | has_blobs;
|
|
mcl->ClSize = sz*ap->cs.p_code.NOfClauses;
|
|
mcl->ClPred = ap;
|
|
mcl->ClItemSize = sz;
|
|
mcl->ClNext = NULL;
|
|
cl =
|
|
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
|
|
ptr = mcl->ClCode;
|
|
while (TRUE) {
|
|
memcpy((void *)ptr, (void *)cl->ClCode, sz);
|
|
if (has_blobs) {
|
|
ClDiff = (char *)(ptr)-(char *)cl->ClCode;
|
|
restore_opcodes(ptr, NULL);
|
|
}
|
|
ptr = (yamop *)((char *)ptr + sz);
|
|
if (cl->ClCode == ap->cs.p_code.LastClause)
|
|
break;
|
|
cl = cl->ClNext;
|
|
}
|
|
ptr->opc = Yap_opcode(_Ystop);
|
|
cl =
|
|
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
|
|
/* recover the space spent on the original clauses */
|
|
while (TRUE) {
|
|
StaticClause *ncl, *curcl = cl;
|
|
|
|
ncl = cl->ClNext;
|
|
Yap_InformOfRemoval((CODEADDR)cl);
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
Yap_FreeCodeSpace((ADDR)cl);
|
|
if (curcl->ClCode == ap->cs.p_code.LastClause)
|
|
break;
|
|
cl = ncl;
|
|
}
|
|
ap->cs.p_code.FirstClause =
|
|
ap->cs.p_code.LastClause =
|
|
mcl->ClCode;
|
|
ap->PredFlags |= MegaClausePredFlag;
|
|
}
|
|
|
|
|
|
static void
|
|
split_megaclause(PredEntry *ap)
|
|
{
|
|
StaticClause *start = NULL, *prev = NULL;
|
|
MegaClause *mcl;
|
|
yamop *ptr;
|
|
UInt ncls = ap->cs.p_code.NOfClauses, i;
|
|
|
|
RemoveIndexation(ap);
|
|
mcl =
|
|
ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
|
|
for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
|
|
StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(sizeof(StaticClause)+mcl->ClItemSize+(UInt)NEXTOP((yamop *)NULL,p));
|
|
if (new == NULL) {
|
|
if (!Yap_growheap(FALSE, (sizeof(StaticClause)+mcl->ClItemSize)*(ncls-i), NULL)) {
|
|
while (start) {
|
|
StaticClause *cl = start;
|
|
start = cl->ClNext;
|
|
Yap_InformOfRemoval((CODEADDR)cl);
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
Yap_FreeCodeSpace((char *)cl);
|
|
}
|
|
if (ap->ArityOfPE) {
|
|
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s/%d\n",RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,ap->ArityOfPE);
|
|
} else {
|
|
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s\n", RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
Yap_ClauseSpace += sizeof(StaticClause)+mcl->ClItemSize+(UInt)NEXTOP((yamop *)NULL,p);
|
|
new->ClFlags = StaticMask|FactMask;
|
|
new->ClSize = mcl->ClItemSize;
|
|
new->usc.ClPred = ap;
|
|
new->ClNext = NULL;
|
|
memcpy((void *)new->ClCode, (void *)ptr, mcl->ClItemSize);
|
|
if (prev) {
|
|
prev->ClNext = new;
|
|
} else {
|
|
start = new;
|
|
}
|
|
ptr = (yamop *)((char *)ptr + mcl->ClItemSize);
|
|
prev = new;
|
|
}
|
|
ap->PredFlags &= ~MegaClausePredFlag;
|
|
ap->cs.p_code.FirstClause = start->ClCode;
|
|
ap->cs.p_code.LastClause = prev->ClCode;
|
|
}
|
|
|
|
|
|
|
|
/******************************************************************
|
|
|
|
Indexation Info
|
|
|
|
******************************************************************/
|
|
#define ByteAdr(X) ((Int) &(X))
|
|
|
|
/* Index a prolog pred, given its predicate entry */
|
|
/* ap is already locked. */
|
|
static void
|
|
IPred(PredEntry *ap, UInt NSlots, yamop *next_pc)
|
|
{
|
|
yamop *BaseAddr;
|
|
|
|
#ifdef DEBUG
|
|
if (Yap_Option['i' - 'a' + 1]) {
|
|
Term tmod = ap->ModuleOfPred;
|
|
if (!tmod)
|
|
tmod = TermProlog;
|
|
Yap_DebugPutc(Yap_c_error_stream,'\t');
|
|
Yap_DebugPlWrite(tmod);
|
|
Yap_DebugPutc(Yap_c_error_stream,':');
|
|
if (ap->ModuleOfPred == IDB_MODULE) {
|
|
Term t = Deref(ARG1);
|
|
if (IsAtomTerm(t)) {
|
|
Yap_DebugPlWrite(t);
|
|
} else if (IsIntegerTerm(t)) {
|
|
Yap_DebugPlWrite(t);
|
|
} else {
|
|
Functor f = FunctorOfTerm(t);
|
|
Atom At = NameOfFunctor(f);
|
|
Yap_DebugPlWrite(MkAtomTerm(At));
|
|
Yap_DebugPutc(Yap_c_error_stream,'/');
|
|
Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
|
|
}
|
|
} else {
|
|
if (ap->ArityOfPE == 0) {
|
|
Atom At = (Atom)ap->FunctorOfPred;
|
|
Yap_DebugPlWrite(MkAtomTerm(At));
|
|
} else {
|
|
Functor f = ap->FunctorOfPred;
|
|
Atom At = NameOfFunctor(f);
|
|
Yap_DebugPlWrite(MkAtomTerm(At));
|
|
Yap_DebugPutc(Yap_c_error_stream,'/');
|
|
Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
|
|
}
|
|
}
|
|
Yap_DebugPutc(Yap_c_error_stream,'\n');
|
|
}
|
|
#endif
|
|
/* Do not try to index a dynamic predicate or one whithout args */
|
|
if (is_dynamic(ap)) {
|
|
Yap_Error(SYSTEM_ERROR,TermNil,"trying to index a dynamic predicate");
|
|
return;
|
|
}
|
|
if ((BaseAddr = Yap_PredIsIndexable(ap, NSlots, next_pc)) != NULL) {
|
|
ap->cs.p_code.TrueCodeOfPred = BaseAddr;
|
|
ap->PredFlags |= IndexedPredFlag;
|
|
}
|
|
if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
|
|
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
} else if (ap->PredFlags & LogUpdatePredFlag &&
|
|
ap->ModuleOfPred != IDB_MODULE) {
|
|
ap->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
#endif
|
|
} else {
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
|
|
ap->OpcodeOfPred = ap->CodeOfPred->opc;
|
|
}
|
|
#ifdef DEBUG
|
|
if (Yap_Option['i' - 'a' + 1])
|
|
Yap_DebugPutc(Yap_c_error_stream,'\n');
|
|
#endif
|
|
}
|
|
|
|
void
|
|
Yap_IPred(PredEntry *p, UInt NSlots, yamop *next_pc)
|
|
{
|
|
IPred(p, NSlots, next_pc);
|
|
}
|
|
|
|
#define GONEXT(TYPE) code_p = ((yamop *)(&(code_p->u.TYPE.next)))
|
|
|
|
static void
|
|
RemoveMainIndex(PredEntry *ap)
|
|
{
|
|
yamop *First = ap->cs.p_code.FirstClause;
|
|
int spied = ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag);
|
|
|
|
ap->PredFlags &= ~IndexedPredFlag;
|
|
if (First == NULL) {
|
|
ap->cs.p_code.TrueCodeOfPred = FAILCODE;
|
|
} else {
|
|
ap->cs.p_code.TrueCodeOfPred = First;
|
|
}
|
|
if (First != NULL && spied) {
|
|
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
} else if (ap->cs.p_code.NOfClauses > 1
|
|
#ifdef TABLING
|
|
||ap->PredFlags & TabledPredFlag
|
|
#endif /* TABLING */
|
|
) {
|
|
ap->OpcodeOfPred = INDEX_OPCODE;
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
} else {
|
|
ap->OpcodeOfPred = ap->cs.p_code.TrueCodeOfPred->opc;
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (ap->PredFlags & LogUpdatePredFlag &&
|
|
ap->ModuleOfPred != IDB_MODULE) {
|
|
ap->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
}
|
|
|
|
static void
|
|
decrease_ref_counter(yamop *ptr, yamop *b, yamop *e, yamop *sc)
|
|
{
|
|
if (ptr != FAILCODE && ptr != sc && (ptr < b || ptr > e)) {
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(ptr);
|
|
cl->ClRefCount--;
|
|
if (cl->ClFlags & ErasedMask &&
|
|
!(cl->ClRefCount) &&
|
|
!(cl->ClFlags & InUseMask)) {
|
|
/* last ref to the clause */
|
|
Yap_ErLogUpdCl(cl);
|
|
}
|
|
}
|
|
}
|
|
|
|
static yamop *
|
|
release_wcls(yamop *cop, OPCODE ecs)
|
|
{
|
|
if (cop->opc == ecs) {
|
|
cop->u.sssllp.s3--;
|
|
if (!cop->u.sssllp.s3) {
|
|
UInt sz = (UInt)NEXTOP((yamop *)NULL,sssllp)+cop->u.sssllp.s1*sizeof(yamop *);
|
|
LOCK(ExpandClausesListLock);
|
|
#ifdef DEBUG
|
|
Yap_expand_clauses_sz -= sz;
|
|
Yap_ExpandClauses--;
|
|
#endif
|
|
if (cop->u.sssllp.p->PredFlags & LogUpdatePredFlag) {
|
|
Yap_LUIndexSpace_EXT -= sz;
|
|
} else {
|
|
Yap_IndexSpace_EXT -= sz;
|
|
}
|
|
if (ExpandClausesFirst == cop)
|
|
ExpandClausesFirst = cop->u.sssllp.snext;
|
|
if (ExpandClausesLast == cop) {
|
|
ExpandClausesLast = cop->u.sssllp.sprev;
|
|
}
|
|
if (cop->u.sssllp.sprev) {
|
|
cop->u.sssllp.sprev->u.sssllp.snext = cop->u.sssllp.snext;
|
|
}
|
|
if (cop->u.sssllp.snext) {
|
|
cop->u.sssllp.snext->u.sssllp.sprev = cop->u.sssllp.sprev;
|
|
}
|
|
UNLOCK(ExpandClausesListLock);
|
|
Yap_InformOfRemoval((CODEADDR)cop);
|
|
Yap_FreeCodeSpace((char *)cop);
|
|
}
|
|
}
|
|
return FAILCODE;
|
|
}
|
|
|
|
|
|
static void
|
|
cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code)
|
|
{
|
|
OPCODE ecs = Yap_opcode(_expand_clauses);
|
|
|
|
while (ipc) {
|
|
op_numbers op = Yap_op_from_opcode(ipc->opc);
|
|
/* fprintf(stderr,"op: %d %p->%p\n", op, ipc, end);*/
|
|
switch(op) {
|
|
case _Ystop:
|
|
/* end of clause, for now */
|
|
return;
|
|
case _index_dbref:
|
|
case _index_blob:
|
|
case _index_long:
|
|
ipc = NEXTOP(ipc,e);
|
|
break;
|
|
case _lock_lu:
|
|
case _unlock_lu:
|
|
/* locking should be done already */
|
|
ipc = NEXTOP(ipc,e);
|
|
case _retry_profiled:
|
|
case _count_retry:
|
|
ipc = NEXTOP(ipc,p);
|
|
break;
|
|
case _try_clause2:
|
|
case _try_clause3:
|
|
case _try_clause4:
|
|
ipc = NEXTOP(ipc,l);
|
|
break;
|
|
case _retry2:
|
|
case _retry3:
|
|
case _retry4:
|
|
decrease_ref_counter(ipc->u.l.l, beg, end, suspend_code);
|
|
ipc = NEXTOP(ipc,l);
|
|
break;
|
|
case _retry:
|
|
case _trust:
|
|
decrease_ref_counter(ipc->u.Otapl.d, beg, end, suspend_code);
|
|
ipc = NEXTOP(ipc,Otapl);
|
|
break;
|
|
case _try_clause:
|
|
case _try_me:
|
|
case _retry_me:
|
|
case _profiled_trust_me:
|
|
case _trust_me:
|
|
case _count_trust_me:
|
|
ipc = NEXTOP(ipc,Otapl);
|
|
break;
|
|
case _try_logical:
|
|
case _retry_logical:
|
|
case _count_retry_logical:
|
|
case _profiled_retry_logical:
|
|
{
|
|
yamop *oipc = ipc;
|
|
decrease_ref_counter(ipc->u.OtaLl.d->ClCode, beg, end, suspend_code);
|
|
ipc = ipc->u.OtaLl.n;
|
|
Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,OtaLl);
|
|
Yap_FreeCodeSpace((ADDR)oipc);
|
|
#ifdef DEBUG
|
|
Yap_DirtyCps--;
|
|
Yap_FreedCps++;
|
|
#endif
|
|
}
|
|
break;
|
|
case _trust_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_trust_logical:
|
|
#ifdef DEBUG
|
|
Yap_DirtyCps--;
|
|
Yap_FreedCps++;
|
|
#endif
|
|
decrease_ref_counter(ipc->u.OtILl.d->ClCode, beg, end, suspend_code);
|
|
Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,OtILl);
|
|
Yap_FreeCodeSpace((ADDR)ipc);
|
|
return;
|
|
case _enter_lu_pred:
|
|
{
|
|
yamop *oipc = ipc;
|
|
if (ipc->u.Ills.I->ClFlags & InUseMask || ipc->u.Ills.I->ClRefCount)
|
|
return;
|
|
#ifdef DEBUG
|
|
Yap_DirtyCps+=ipc->u.Ills.s;
|
|
Yap_LiveCps-=ipc->u.Ills.s;
|
|
#endif
|
|
ipc = ipc->u.Ills.l1;
|
|
/* in case we visit again */
|
|
oipc->u.Ills.l1 = FAILCODE;
|
|
oipc->u.Ills.s = 0;
|
|
}
|
|
break;
|
|
case _try_in:
|
|
case _jump:
|
|
case _jump_if_var:
|
|
ipc->u.l.l = release_wcls(ipc->u.l.l, ecs);
|
|
ipc = NEXTOP(ipc,l);
|
|
break;
|
|
/* instructions type xl */
|
|
case _jump_if_nonvar:
|
|
ipc->u.xll.l1 = release_wcls(ipc->u.xll.l1, ecs);
|
|
ipc = NEXTOP(ipc,xll);
|
|
break;
|
|
/* instructions type p */
|
|
case _user_switch:
|
|
ipc = NEXTOP(ipc,lp);
|
|
break;
|
|
/* instructions type e */
|
|
case _switch_on_type:
|
|
ipc->u.llll.l1 = release_wcls(ipc->u.llll.l1, ecs);
|
|
ipc->u.llll.l2 = release_wcls(ipc->u.llll.l2, ecs);
|
|
ipc->u.llll.l3 = release_wcls(ipc->u.llll.l3, ecs);
|
|
ipc->u.llll.l4 = release_wcls(ipc->u.llll.l4, ecs);
|
|
ipc = NEXTOP(ipc,llll);
|
|
break;
|
|
case _switch_list_nl:
|
|
ipc->u.ollll.l1 = release_wcls(ipc->u.ollll.l1, ecs);
|
|
ipc->u.ollll.l2 = release_wcls(ipc->u.ollll.l2, ecs);
|
|
ipc->u.ollll.l3 = release_wcls(ipc->u.ollll.l3, ecs);
|
|
ipc->u.ollll.l4 = release_wcls(ipc->u.ollll.l4, ecs);
|
|
ipc = NEXTOP(ipc,ollll);
|
|
break;
|
|
case _switch_on_arg_type:
|
|
ipc->u.xllll.l1 = release_wcls(ipc->u.xllll.l1, ecs);
|
|
ipc->u.xllll.l2 = release_wcls(ipc->u.xllll.l2, ecs);
|
|
ipc->u.xllll.l3 = release_wcls(ipc->u.xllll.l3, ecs);
|
|
ipc->u.xllll.l4 = release_wcls(ipc->u.xllll.l4, ecs);
|
|
ipc = NEXTOP(ipc,xllll);
|
|
break;
|
|
case _switch_on_sub_arg_type:
|
|
ipc->u.sllll.l1 = release_wcls(ipc->u.sllll.l1, ecs);
|
|
ipc->u.sllll.l2 = release_wcls(ipc->u.sllll.l2, ecs);
|
|
ipc->u.sllll.l3 = release_wcls(ipc->u.sllll.l3, ecs);
|
|
ipc->u.sllll.l4 = release_wcls(ipc->u.sllll.l4, ecs);
|
|
ipc = NEXTOP(ipc,sllll);
|
|
break;
|
|
case _if_not_then:
|
|
ipc = NEXTOP(ipc,clll);
|
|
break;
|
|
case _switch_on_func:
|
|
case _if_func:
|
|
case _go_on_func:
|
|
case _switch_on_cons:
|
|
case _if_cons:
|
|
case _go_on_cons:
|
|
ipc = NEXTOP(ipc,sssl);
|
|
break;
|
|
case _op_fail:
|
|
return;
|
|
default:
|
|
Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
|
|
return;
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
ipc = (yamop *)((CELL)ipc & ~1);
|
|
#endif
|
|
}
|
|
}
|
|
|
|
void
|
|
Yap_cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *sc)
|
|
{
|
|
cleanup_dangling_indices(ipc, beg, end, sc);
|
|
}
|
|
|
|
static void
|
|
decrease_log_indices(LogUpdIndex *c, yamop *suspend_code)
|
|
{
|
|
/* decrease all reference counters */
|
|
yamop *beg = c->ClCode, *end, *ipc;
|
|
op_numbers op;
|
|
if (c->ClFlags & SwitchTableMask) {
|
|
CELL *end = (CELL *)((char *)c+c->ClSize);
|
|
CELL *beg = (CELL *)(c->ClCode);
|
|
OPCODE ecs = Yap_opcode(_expand_clauses);
|
|
|
|
while (beg < end) {
|
|
yamop **x = (yamop **)(beg+1);
|
|
beg += 2;
|
|
*x = release_wcls(*x, ecs);
|
|
}
|
|
return;
|
|
}
|
|
op = Yap_op_from_opcode(beg->opc);
|
|
end = (yamop *)((CODEADDR)c+c->ClSize);
|
|
ipc = beg;
|
|
cleanup_dangling_indices(ipc, beg, end, suspend_code);
|
|
}
|
|
|
|
static void
|
|
kill_static_child_indxs(StaticIndex *indx, int in_use)
|
|
{
|
|
StaticIndex *cl = indx->ChildIndex;
|
|
while (cl != NULL) {
|
|
StaticIndex *next = cl->SiblingIndex;
|
|
kill_static_child_indxs(cl, in_use);
|
|
cl = next;
|
|
}
|
|
if (in_use) {
|
|
LOCK(DeadStaticIndicesLock);
|
|
indx->SiblingIndex = DeadStaticIndices;
|
|
indx->ChildIndex = NULL;
|
|
DeadStaticIndices = indx;
|
|
UNLOCK(DeadStaticIndicesLock);
|
|
} else {
|
|
Yap_InformOfRemoval((CODEADDR)indx);
|
|
if (indx->ClFlags & SwitchTableMask)
|
|
Yap_IndexSpace_SW -= indx->ClSize;
|
|
else
|
|
Yap_IndexSpace_Tree -= indx->ClSize;
|
|
Yap_FreeCodeSpace((char *)indx);
|
|
}
|
|
}
|
|
|
|
static void
|
|
kill_children(LogUpdIndex *c, PredEntry *ap)
|
|
{
|
|
LogUpdIndex *ncl;
|
|
|
|
c->ClRefCount++;
|
|
ncl = c->ChildIndex;
|
|
/* kill children */
|
|
while (ncl) {
|
|
kill_first_log_iblock(ncl, c, ap);
|
|
ncl = c->ChildIndex;
|
|
}
|
|
c->ClRefCount--;
|
|
}
|
|
|
|
|
|
/* assumes c is already locked */
|
|
static void
|
|
kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
|
{
|
|
/* first, make sure that I killed off all my children, some children may
|
|
remain in case I have tables as children */
|
|
if (parent != NULL) {
|
|
/* sat bye bye */
|
|
/* decrease refs */
|
|
parent->ClRefCount--;
|
|
if (parent->ClFlags & ErasedMask &&
|
|
!(parent->ClFlags & InUseMask) &&
|
|
parent->ClRefCount == 0) {
|
|
/* cool, I can erase the father too. */
|
|
if (parent->ClFlags & SwitchRootMask) {
|
|
kill_off_lu_block(parent, NULL, ap);
|
|
} else {
|
|
kill_off_lu_block(parent, parent->ParentIndex, ap);
|
|
}
|
|
}
|
|
}
|
|
decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
|
|
/* remove from list */
|
|
if (c->SiblingIndex)
|
|
c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
|
|
if (c->PrevSiblingIndex) {
|
|
c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
|
|
} else {
|
|
DBErasedIList = c->SiblingIndex;
|
|
}
|
|
Yap_InformOfRemoval((CODEADDR)c);
|
|
if (c->ClFlags & SwitchTableMask)
|
|
Yap_LUIndexSpace_SW -= c->ClSize;
|
|
else {
|
|
Yap_LUIndexSpace_Tree -= c->ClSize;
|
|
}
|
|
Yap_FreeCodeSpace((char *)c);
|
|
}
|
|
|
|
static void
|
|
kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
|
|
{
|
|
/* parent is always locked, now I lock myself */
|
|
if (parent != NULL) {
|
|
/* remove myself from parent */
|
|
if (c == parent->ChildIndex) {
|
|
parent->ChildIndex = c->SiblingIndex;
|
|
if (parent->ChildIndex) {
|
|
parent->ChildIndex->PrevSiblingIndex = NULL;
|
|
}
|
|
} else {
|
|
c->PrevSiblingIndex->SiblingIndex =
|
|
c->SiblingIndex;
|
|
if (c->SiblingIndex) {
|
|
c->SiblingIndex->PrevSiblingIndex =
|
|
c->PrevSiblingIndex;
|
|
}
|
|
}
|
|
} else {
|
|
/* I am top node */
|
|
if (ap->cs.p_code.TrueCodeOfPred == c->ClCode) {
|
|
RemoveMainIndex(ap);
|
|
}
|
|
}
|
|
decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
|
|
/* make sure that a child cannot remove us */
|
|
kill_children(c, ap);
|
|
/* check if we are still the main index */
|
|
/* always add to erased list */
|
|
c->SiblingIndex = DBErasedIList;
|
|
c->PrevSiblingIndex = NULL;
|
|
if (DBErasedIList)
|
|
DBErasedIList->PrevSiblingIndex = c;
|
|
DBErasedIList = c;
|
|
if (!((c->ClFlags & InUseMask) || c->ClRefCount)) {
|
|
kill_off_lu_block(c, parent, ap);
|
|
} else {
|
|
if (c->ClFlags & ErasedMask)
|
|
return;
|
|
c->ClFlags |= ErasedMask;
|
|
/* try to move up, so that we don't hold a switch table */
|
|
if (parent != NULL &&
|
|
parent->ClFlags & SwitchTableMask) {
|
|
|
|
c->ParentIndex = parent->ParentIndex;
|
|
parent->ParentIndex->ClRefCount++;
|
|
parent->ClRefCount--;
|
|
}
|
|
}
|
|
}
|
|
|
|
static void
|
|
kill_top_static_iblock(StaticIndex *c, PredEntry *ap)
|
|
{
|
|
kill_static_child_indxs(c, static_in_use(ap, TRUE));
|
|
RemoveMainIndex(ap);
|
|
}
|
|
|
|
void
|
|
Yap_kill_iblock(ClauseUnion *blk, ClauseUnion *parent_blk, PredEntry *ap)
|
|
{
|
|
if (ap->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdIndex *c = (LogUpdIndex *)blk;
|
|
if (parent_blk != NULL) {
|
|
LogUpdIndex *cl = (LogUpdIndex *)parent_blk;
|
|
#if defined(THREADS) || defined(YAPOR)
|
|
/* protect against attempts at erasing */
|
|
cl->ClRefCount++;
|
|
#endif
|
|
kill_first_log_iblock(c, cl, ap);
|
|
#if defined(THREADS) || defined(YAPOR)
|
|
cl->ClRefCount--;
|
|
#endif
|
|
} else {
|
|
kill_first_log_iblock(c, NULL, ap);
|
|
}
|
|
} else {
|
|
StaticIndex *c = (StaticIndex *)blk;
|
|
if (parent_blk != NULL) {
|
|
StaticIndex *cl = parent_blk->si.ChildIndex;
|
|
if (cl == c) {
|
|
parent_blk->si.ChildIndex = c->SiblingIndex;
|
|
} else {
|
|
while (cl->SiblingIndex != c) {
|
|
cl = cl->SiblingIndex;
|
|
}
|
|
cl->SiblingIndex = c->SiblingIndex;
|
|
}
|
|
}
|
|
kill_static_child_indxs(c, static_in_use(ap, TRUE));
|
|
}
|
|
}
|
|
|
|
/*
|
|
This predicate is supposed to be called with a
|
|
lock on the current predicate
|
|
*/
|
|
void
|
|
Yap_ErLogUpdIndex(LogUpdIndex *clau)
|
|
{
|
|
if (clau->ClFlags & ErasedMask) {
|
|
if (!clau->ClRefCount) {
|
|
decrease_log_indices(clau, (yamop *)&(clau->ClPred->cs.p_code.ExpandCode));
|
|
if (clau->ClFlags & SwitchRootMask) {
|
|
kill_off_lu_block(clau, NULL, clau->ClPred);
|
|
} else {
|
|
kill_off_lu_block(clau, clau->ParentIndex, clau->ClPred);
|
|
}
|
|
}
|
|
/* otherwise, nothing I can do, I have been erased already */
|
|
return;
|
|
}
|
|
if (clau->ClFlags & SwitchRootMask) {
|
|
kill_first_log_iblock(clau, NULL, clau->ClPred);
|
|
} else {
|
|
#if defined(THREADS) || defined(YAPOR)
|
|
/* protect against attempts at erasing */
|
|
clau->ClRefCount++;
|
|
#endif
|
|
kill_first_log_iblock(clau, clau->ParentIndex, clau->ClPred);
|
|
#if defined(THREADS) || defined(YAPOR)
|
|
/* protect against attempts at erasing */
|
|
clau->ClRefCount--;
|
|
#endif
|
|
}
|
|
}
|
|
|
|
/* Routine used when wanting to remove the indexation */
|
|
/* ap is known to already have been locked for WRITING */
|
|
static int
|
|
RemoveIndexation(PredEntry *ap)
|
|
{
|
|
if (ap->OpcodeOfPred == INDEX_OPCODE) {
|
|
return TRUE;
|
|
}
|
|
if (ap->PredFlags & LogUpdatePredFlag) {
|
|
kill_first_log_iblock(ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred), NULL, ap);
|
|
} else {
|
|
StaticIndex *cl;
|
|
|
|
cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
|
|
|
|
kill_top_static_iblock(cl, ap);
|
|
|
|
}
|
|
return TRUE;
|
|
}
|
|
|
|
int
|
|
Yap_RemoveIndexation(PredEntry *ap)
|
|
{
|
|
return RemoveIndexation(ap);
|
|
}
|
|
/******************************************************************
|
|
|
|
Adding clauses
|
|
|
|
******************************************************************/
|
|
|
|
|
|
#define assertz 0
|
|
#define consult 1
|
|
#define asserta 2
|
|
|
|
/* p is already locked */
|
|
static void
|
|
retract_all(PredEntry *p, int in_use)
|
|
{
|
|
yamop *q;
|
|
|
|
q = p->cs.p_code.FirstClause;
|
|
if (q != NULL) {
|
|
if (p->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(q);
|
|
do {
|
|
LogUpdClause *ncl = cl->ClNext;
|
|
Yap_ErLogUpdCl(cl);
|
|
cl = ncl;
|
|
} while (cl != NULL);
|
|
} else if (p->PredFlags & MegaClausePredFlag) {
|
|
MegaClause *cl = ClauseCodeToMegaClause(q);
|
|
|
|
if (in_use || cl->ClFlags & HasBlobsMask) {
|
|
LOCK(DeadMegaClausesLock);
|
|
cl->ClNext = DeadMegaClauses;
|
|
DeadMegaClauses = cl;
|
|
UNLOCK(DeadMegaClausesLock);
|
|
} else {
|
|
Yap_InformOfRemoval((CODEADDR)cl);
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
Yap_FreeCodeSpace((char *)cl);
|
|
}
|
|
/* make sure this is not a MegaClause */
|
|
p->PredFlags &= ~MegaClausePredFlag;
|
|
p->cs.p_code.NOfClauses = 0;
|
|
} else {
|
|
StaticClause *cl = ClauseCodeToStaticClause(q);
|
|
|
|
while (cl) {
|
|
StaticClause *ncl = cl->ClNext;
|
|
|
|
if (in_use|| cl->ClFlags & HasBlobsMask) {
|
|
LOCK(DeadStaticClausesLock);
|
|
cl->ClNext = DeadStaticClauses;
|
|
DeadStaticClauses = cl;
|
|
UNLOCK(DeadStaticClausesLock);
|
|
} else {
|
|
Yap_InformOfRemoval((CODEADDR)cl);
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
Yap_FreeCodeSpace((char *)cl);
|
|
}
|
|
p->cs.p_code.NOfClauses--;
|
|
if (!ncl) break;
|
|
cl = ncl;
|
|
}
|
|
}
|
|
}
|
|
p->cs.p_code.FirstClause = NULL;
|
|
p->cs.p_code.LastClause = NULL;
|
|
if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag)) {
|
|
p->OpcodeOfPred = FAIL_OPCODE;
|
|
} else {
|
|
p->OpcodeOfPred = UNDEF_OPCODE;
|
|
}
|
|
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->PredFlags & LogUpdatePredFlag &&
|
|
p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
p->StatisticsForPred.NOfEntries = 0;
|
|
p->StatisticsForPred.NOfHeadSuccesses = 0;
|
|
p->StatisticsForPred.NOfRetries = 0;
|
|
if (PROFILING) {
|
|
p->PredFlags |= ProfiledPredFlag;
|
|
} else
|
|
p->PredFlags &= ~ProfiledPredFlag;
|
|
if (CALL_COUNTING) {
|
|
p->PredFlags |= CountPredFlag;
|
|
} else
|
|
p->PredFlags &= ~CountPredFlag;
|
|
#ifdef YAPOR
|
|
if (SEQUENTIAL_IS_DEFAULT) {
|
|
p->PredFlags |= SequentialPredFlag;
|
|
}
|
|
#endif /* YAPOR */
|
|
Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
add_first_static(PredEntry *p, yamop *cp, int spy_flag)
|
|
{
|
|
yamop *pt = cp;
|
|
|
|
if (is_logupd(p)) {
|
|
if (p == PredGoalExpansion) {
|
|
PRED_GOAL_EXPANSION_ON = TRUE;
|
|
Yap_InitComma();
|
|
}
|
|
} else {
|
|
#ifdef YAPOR
|
|
if (SEQUENTIAL_IS_DEFAULT) {
|
|
p->PredFlags |= SequentialPredFlag;
|
|
}
|
|
#endif /* YAPOR */
|
|
#ifdef TABLING
|
|
if (is_tabled(p)) {
|
|
p->OpcodeOfPred = INDEX_OPCODE;
|
|
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif /* TABLING */
|
|
}
|
|
p->cs.p_code.TrueCodeOfPred = pt;
|
|
p->cs.p_code.FirstClause = p->cs.p_code.LastClause = cp;
|
|
p->OpcodeOfPred = pt->opc;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->PredFlags & LogUpdatePredFlag &&
|
|
p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
} else
|
|
#endif
|
|
p->CodeOfPred = pt;
|
|
p->cs.p_code.NOfClauses = 1;
|
|
p->StatisticsForPred.NOfEntries = 0;
|
|
p->StatisticsForPred.NOfHeadSuccesses = 0;
|
|
p->StatisticsForPred.NOfRetries = 0;
|
|
if (PROFILING) {
|
|
p->PredFlags |= ProfiledPredFlag;
|
|
spy_flag = TRUE;
|
|
} else {
|
|
p->PredFlags &= ~ProfiledPredFlag;
|
|
}
|
|
if (CALL_COUNTING) {
|
|
p->PredFlags |= CountPredFlag;
|
|
spy_flag = TRUE;
|
|
} else {
|
|
p->PredFlags &= ~CountPredFlag;
|
|
}
|
|
if (spy_flag) {
|
|
p->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
if ((yap_flags[SOURCE_MODE_FLAG] ||
|
|
(p->PredFlags & MultiFileFlag)) &&
|
|
!(p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
p->PredFlags |= SourcePredFlag;
|
|
} else {
|
|
p->PredFlags &= ~SourcePredFlag;
|
|
}
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag)
|
|
{
|
|
yamop *ncp = ((DynamicClause *)NULL)->ClCode;
|
|
DynamicClause *cl;
|
|
if (p == PredGoalExpansion) {
|
|
PRED_GOAL_EXPANSION_ON = TRUE;
|
|
Yap_InitComma();
|
|
}
|
|
p->StatisticsForPred.NOfEntries = 0;
|
|
p->StatisticsForPred.NOfHeadSuccesses = 0;
|
|
p->StatisticsForPred.NOfRetries = 0;
|
|
if (PROFILING) {
|
|
p->PredFlags |= ProfiledPredFlag;
|
|
spy_flag = TRUE;
|
|
} else {
|
|
p->PredFlags &= ~ProfiledPredFlag;
|
|
}
|
|
if (CALL_COUNTING) {
|
|
p->PredFlags |= CountPredFlag;
|
|
spy_flag = TRUE;
|
|
} else {
|
|
p->PredFlags &= ~CountPredFlag;
|
|
}
|
|
#ifdef YAPOR
|
|
p->PredFlags |= SequentialPredFlag;
|
|
#endif /* YAPOR */
|
|
/* allocate starter block, containing info needed to start execution,
|
|
* that is a try_mark to start the code and a fail to finish things up */
|
|
cl =
|
|
(DynamicClause *) Yap_AllocCodeSpace((Int)NEXTOP(NEXTOP(NEXTOP(ncp,Otapl),e),l));
|
|
if (cl == NIL) {
|
|
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"Heap crashed against Stacks");
|
|
return;
|
|
}
|
|
Yap_ClauseSpace += (Int)NEXTOP(NEXTOP(NEXTOP(ncp,Otapl),e),l);
|
|
/* skip the first entry, this contains the back link and will always be
|
|
empty for this entry */
|
|
ncp = (yamop *)(((CELL *)ncp)+1);
|
|
/* next we have the flags. For this block mainly say whether we are
|
|
* being spied */
|
|
cl->ClFlags = DynamicMask;
|
|
ncp = cl->ClCode;
|
|
INIT_LOCK(cl->ClLock);
|
|
INIT_CLREF_COUNT(cl);
|
|
/* next, set the first instruction to execute in the dyamic
|
|
* predicate */
|
|
if (spy_flag)
|
|
p->OpcodeOfPred = ncp->opc = Yap_opcode(_spy_or_trymark);
|
|
else
|
|
p->OpcodeOfPred = ncp->opc = Yap_opcode(_try_and_mark);
|
|
ncp->u.Otapl.s = p->ArityOfPE;
|
|
ncp->u.Otapl.p = p;
|
|
ncp->u.Otapl.d = cp;
|
|
/* This is the point we enter the code */
|
|
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = ncp;
|
|
p->cs.p_code.NOfClauses = 1;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->PredFlags & LogUpdatePredFlag &&
|
|
p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
/* set the first clause to have a retry and mark which will
|
|
* backtrack to the previous block */
|
|
if (p->PredFlags & ProfiledPredFlag)
|
|
cp->opc = Yap_opcode(_profiled_retry_and_mark);
|
|
else if (p->PredFlags & CountPredFlag)
|
|
cp->opc = Yap_opcode(_count_retry_and_mark);
|
|
else
|
|
cp->opc = Yap_opcode(_retry_and_mark);
|
|
cp->u.Otapl.s = p->ArityOfPE;
|
|
cp->u.Otapl.p = p;
|
|
cp->u.Otapl.d = ncp;
|
|
/* also, keep a backpointer for the days you delete the clause */
|
|
ClauseCodeToDynamicClause(cp)->ClPrevious = ncp;
|
|
/* Don't forget to say who is the only clause for the predicate so
|
|
far */
|
|
p->cs.p_code.LastClause = p->cs.p_code.FirstClause = cp;
|
|
/* we're only missing what to do when we actually exit the procedure
|
|
*/
|
|
ncp = NEXTOP(ncp,Otapl);
|
|
/* and the last instruction to execute to exit the predicate, note
|
|
the retry is pointing to this pseudo clause */
|
|
ncp->opc = Yap_opcode(_trust_fail);
|
|
/* we're only missing what to do when we actually exit the procedure
|
|
*/
|
|
/* and close the code */
|
|
ncp = NEXTOP(ncp,e);
|
|
ncp->opc = Yap_opcode(_Ystop);
|
|
ncp->u.l.l = cl->ClCode;
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
asserta_stat_clause(PredEntry *p, yamop *q, int spy_flag)
|
|
{
|
|
StaticClause *cl = ClauseCodeToStaticClause(q);
|
|
|
|
p->cs.p_code.NOfClauses++;
|
|
if (is_logupd(p)) {
|
|
LogUpdClause
|
|
*clp = ClauseCodeToLogUpdClause(p->cs.p_code.FirstClause),
|
|
*clq = ClauseCodeToLogUpdClause(q);
|
|
clq->ClPrev = NULL;
|
|
clq->ClNext = clp;
|
|
clp->ClPrev = clq;
|
|
p->cs.p_code.FirstClause = q;
|
|
if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
|
|
p->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
} else if (!(p->PredFlags & IndexedPredFlag)) {
|
|
p->OpcodeOfPred = INDEX_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
return;
|
|
}
|
|
cl->ClNext = ClauseCodeToStaticClause(p->cs.p_code.FirstClause);
|
|
p->cs.p_code.FirstClause = q;
|
|
p->cs.p_code.TrueCodeOfPred = q;
|
|
if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
|
|
p->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
} else if (!(p->PredFlags & IndexedPredFlag)) {
|
|
p->OpcodeOfPred = INDEX_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
p->cs.p_code.LastClause->u.Otapl.d = q;
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
asserta_dynam_clause(PredEntry *p, yamop *cp)
|
|
{
|
|
yamop *q;
|
|
DynamicClause *cl = ClauseCodeToDynamicClause(cp);
|
|
q = cp;
|
|
LOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
|
|
/* also, keep backpointers for the days we'll delete all the clause */
|
|
ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClPrevious = q;
|
|
cl->ClPrevious = (yamop *)(p->CodeOfPred);
|
|
cl->ClFlags |= DynamicMask;
|
|
UNLOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
|
|
q->u.Otapl.d = p->cs.p_code.FirstClause;
|
|
q->u.Otapl.s = p->ArityOfPE;
|
|
q->u.Otapl.p = p;
|
|
if (p->PredFlags & ProfiledPredFlag)
|
|
cp->opc = Yap_opcode(_profiled_retry_and_mark);
|
|
else if (p->PredFlags & CountPredFlag)
|
|
cp->opc = Yap_opcode(_count_retry_and_mark);
|
|
else
|
|
cp->opc = Yap_opcode(_retry_and_mark);
|
|
cp->u.Otapl.s = p->ArityOfPE;
|
|
cp->u.Otapl.p = p;
|
|
p->cs.p_code.FirstClause = cp;
|
|
q = p->CodeOfPred;
|
|
q->u.Otapl.d = cp;
|
|
q->u.Otapl.s = p->ArityOfPE;
|
|
q->u.Otapl.p = p;
|
|
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
assertz_stat_clause(PredEntry *p, yamop *cp, int spy_flag)
|
|
{
|
|
yamop *pt;
|
|
|
|
p->cs.p_code.NOfClauses++;
|
|
pt = p->cs.p_code.LastClause;
|
|
if (is_logupd(p)) {
|
|
LogUpdClause
|
|
*clp = ClauseCodeToLogUpdClause(cp),
|
|
*clq = ClauseCodeToLogUpdClause(pt);
|
|
|
|
clq->ClNext = clp;
|
|
clp->ClPrev = clq;
|
|
clp->ClNext = NULL;
|
|
p->cs.p_code.LastClause = cp;
|
|
if (!(p->PredFlags & IndexedPredFlag)) {
|
|
p->OpcodeOfPred = INDEX_OPCODE;
|
|
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
if (p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
|
|
p->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
return;
|
|
} else {
|
|
StaticClause *cl = ClauseCodeToStaticClause(pt);
|
|
|
|
cl->ClNext = ClauseCodeToStaticClause(cp);
|
|
}
|
|
if (p->cs.p_code.FirstClause == p->cs.p_code.LastClause) {
|
|
if (!(p->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag))) {
|
|
p->OpcodeOfPred = INDEX_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
}
|
|
p->cs.p_code.LastClause = cp;
|
|
}
|
|
|
|
/* p is already locked */
|
|
static void
|
|
assertz_dynam_clause(PredEntry *p, yamop *cp)
|
|
{
|
|
yamop *q;
|
|
DynamicClause *cl = ClauseCodeToDynamicClause(cp);
|
|
|
|
q = p->cs.p_code.LastClause;
|
|
LOCK(ClauseCodeToDynamicClause(q)->ClLock);
|
|
q->u.Otapl.d = cp;
|
|
p->cs.p_code.LastClause = cp;
|
|
/* also, keep backpointers for the days we'll delete all the clause */
|
|
cl->ClPrevious = q;
|
|
cl->ClFlags |= DynamicMask;
|
|
UNLOCK(ClauseCodeToDynamicClause(q)->ClLock);
|
|
q = (yamop *)cp;
|
|
if (p->PredFlags & ProfiledPredFlag)
|
|
q->opc = Yap_opcode(_profiled_retry_and_mark);
|
|
else if (p->PredFlags & CountPredFlag)
|
|
q->opc = Yap_opcode(_count_retry_and_mark);
|
|
else
|
|
q->opc = Yap_opcode(_retry_and_mark);
|
|
q->u.Otapl.d = p->CodeOfPred;
|
|
q->u.Otapl.s = p->ArityOfPE;
|
|
q->u.Otapl.p = p;
|
|
p->cs.p_code.NOfClauses++;
|
|
}
|
|
|
|
static void expand_consult(void)
|
|
{
|
|
consult_obj *new_cl, *new_cs;
|
|
UInt OldConsultCapacity = ConsultCapacity;
|
|
|
|
/* now double consult capacity */
|
|
ConsultCapacity += InitialConsultCapacity;
|
|
/* I assume it always works ;-) */
|
|
while ((new_cl = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*ConsultCapacity)) == NULL) {
|
|
if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) {
|
|
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,Yap_ErrorMessage);
|
|
return;
|
|
}
|
|
}
|
|
new_cs = new_cl + InitialConsultCapacity;
|
|
/* start copying */
|
|
memcpy((void *)new_cs, (void *)ConsultLow, OldConsultCapacity*sizeof(consult_obj));
|
|
/* copying done, release old space */
|
|
Yap_FreeCodeSpace((char *)ConsultLow);
|
|
/* next, set up pointers correctly */
|
|
new_cs += (ConsultSp-ConsultLow);
|
|
/* put ConsultBase at same offset as before move */
|
|
ConsultBase = ConsultBase+(new_cs-ConsultSp);
|
|
/* new consult pointer */
|
|
ConsultSp = new_cs;
|
|
/* new end of memory */
|
|
ConsultLow = new_cl;
|
|
}
|
|
|
|
/* p was already locked */
|
|
static int
|
|
not_was_reconsulted(PredEntry *p, Term t, int mode)
|
|
{
|
|
register consult_obj *fp;
|
|
Prop p0 = AbsProp((PropEntry *)p);
|
|
|
|
if (p == LastAssertedPred)
|
|
return FALSE;
|
|
LastAssertedPred = p;
|
|
if (!ConsultSp) {
|
|
InitConsultStack();
|
|
}
|
|
if (p->cs.p_code.NOfClauses) {
|
|
for (fp = ConsultSp; fp < ConsultBase; ++fp)
|
|
if (fp->p == p0)
|
|
break;
|
|
} else {
|
|
fp = ConsultBase;
|
|
}
|
|
if (fp != ConsultBase)
|
|
return FALSE;
|
|
if (mode) {
|
|
if (ConsultSp == ConsultLow+1) {
|
|
expand_consult();
|
|
}
|
|
--ConsultSp;
|
|
ConsultSp->p = p0;
|
|
if (ConsultBase[1].mode &&
|
|
!(p->PredFlags & MultiFileFlag)) /* we are in reconsult mode */ {
|
|
retract_all(p, static_in_use(p,TRUE));
|
|
}
|
|
p->src.OwnerFile = YapConsultingFile();
|
|
}
|
|
return TRUE; /* careful */
|
|
}
|
|
|
|
static void
|
|
addcl_permission_error(AtomEntry *ap, Int Arity, int in_use)
|
|
{
|
|
Term t, ti[2];
|
|
|
|
ti[0] = MkAtomTerm(AbsAtom(ap));
|
|
ti[1] = MkIntegerTerm(Arity);
|
|
t = Yap_MkApplTerm(FunctorSlash, 2, ti);
|
|
Yap_ErrorMessage = Yap_ErrorSay;
|
|
Yap_Error_Term = t;
|
|
Yap_Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
|
|
if (in_use) {
|
|
if (Arity == 0)
|
|
sprintf(Yap_ErrorMessage, "static predicate %s is in use", ap->StrOfAE);
|
|
else
|
|
sprintf(Yap_ErrorMessage,
|
|
#if SHORT_INTS
|
|
"static predicate %s/%ld is in use",
|
|
#else
|
|
"static predicate %s/%d is in use",
|
|
#endif
|
|
ap->StrOfAE, Arity);
|
|
} else {
|
|
if (Arity == 0)
|
|
sprintf(Yap_ErrorMessage, "system predicate %s", ap->StrOfAE);
|
|
else
|
|
sprintf(Yap_ErrorMessage,
|
|
#if SHORT_INTS
|
|
"system predicate %s/%ld",
|
|
#else
|
|
"system predicate %s/%d",
|
|
#endif
|
|
ap->StrOfAE, Arity);
|
|
}
|
|
}
|
|
|
|
|
|
static int
|
|
is_fact(Term t)
|
|
{
|
|
Term a1;
|
|
|
|
if (IsAtomTerm(t))
|
|
return TRUE;
|
|
if (FunctorOfTerm(t) != FunctorAssert)
|
|
return TRUE;
|
|
a1 = ArgOfTerm(2, t);
|
|
if (a1 == MkAtomTerm(AtomTrue))
|
|
return TRUE;
|
|
return FALSE;
|
|
}
|
|
|
|
static void
|
|
mark_preds_with_this_func(Functor f, Prop p0)
|
|
{
|
|
PredEntry *pe = RepPredProp(p0);
|
|
UInt i;
|
|
|
|
pe->PredFlags |= GoalExPredFlag;
|
|
for (i = 0; i < PredHashTableSize; i++) {
|
|
PredEntry *p = PredHash[i];
|
|
|
|
while (p) {
|
|
Prop nextp = p->NextOfPE;
|
|
if (p->FunctorOfPred == f)
|
|
p->PredFlags |= GoalExPredFlag;
|
|
p = RepPredProp(nextp);
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
static int
|
|
addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref)
|
|
/*
|
|
*
|
|
mode
|
|
0 assertz
|
|
1 consult
|
|
2 asserta
|
|
*/
|
|
{
|
|
PredEntry *p;
|
|
int spy_flag = FALSE;
|
|
Atom at;
|
|
UInt Arity;
|
|
CELL pflags;
|
|
Term tf;
|
|
|
|
|
|
if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
|
|
tf = ArgOfTerm(1, t);
|
|
else
|
|
tf = t;
|
|
if (IsAtomTerm(tf)) {
|
|
at = AtomOfTerm(tf);
|
|
p = RepPredProp(PredPropByAtom(at, mod));
|
|
Arity = 0;
|
|
} else {
|
|
Functor f = FunctorOfTerm(tf);
|
|
Arity = ArityOfFunctor(f);
|
|
at = NameOfFunctor(f);
|
|
p = RepPredProp(PredPropByFunc(f, mod));
|
|
}
|
|
Yap_PutValue(AtomAbol, TermNil);
|
|
LOCK(p->PELock);
|
|
pflags = p->PredFlags;
|
|
/* we are redefining a prolog module predicate */
|
|
if ((pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) ||
|
|
(p->ModuleOfPred == PROLOG_MODULE &&
|
|
mod != TermProlog && mod) ) {
|
|
addcl_permission_error(RepAtom(at), Arity, FALSE);
|
|
UNLOCK(p->PELock);
|
|
return TermNil;
|
|
}
|
|
/* we are redefining a prolog module predicate */
|
|
if (pflags & MegaClausePredFlag) {
|
|
split_megaclause(p);
|
|
}
|
|
/* The only problem we have now is when we need to throw away
|
|
Indexing blocks
|
|
*/
|
|
if (pflags & IndexedPredFlag) {
|
|
Yap_AddClauseToIndex(p, cp, mode == asserta);
|
|
}
|
|
if (pflags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag))
|
|
spy_flag = TRUE;
|
|
if (p == PredGoalExpansion) {
|
|
Term tg = ArgOfTerm(1, tf);
|
|
Term tm = ArgOfTerm(2, tf);
|
|
|
|
if (IsVarTerm(tg) || IsVarTerm(tm)) {
|
|
if (!IsVarTerm(tg)) {
|
|
/* this is the complicated case, first I need to inform
|
|
predicates for this functor */
|
|
PRED_GOAL_EXPANSION_FUNC = TRUE;
|
|
if (IsAtomTerm(tg)) {
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(tg));
|
|
Prop p0 = ae->PropsOfAE;
|
|
int found = FALSE;
|
|
|
|
while (p0) {
|
|
PredEntry *pe = RepPredProp(p0);
|
|
if (pe->KindOfPE == PEProp) {
|
|
pe->PredFlags |= GoalExPredFlag;
|
|
found = TRUE;
|
|
}
|
|
p0 = pe->NextOfPE;
|
|
}
|
|
if (!found) {
|
|
PredEntry *npe = RepPredProp(PredPropByAtom(AtomOfTerm(tg),IDB_MODULE));
|
|
npe->PredFlags |= GoalExPredFlag;
|
|
}
|
|
} else if (IsApplTerm(tg)) {
|
|
FunctorEntry *fe = (FunctorEntry *)FunctorOfTerm(tg);
|
|
Prop p0;
|
|
|
|
p0 = fe->PropsOfFE;
|
|
if (p0) {
|
|
mark_preds_with_this_func(FunctorOfTerm(tg), p0);
|
|
} else {
|
|
Term mod = CurrentModule;
|
|
PredEntry *npe;
|
|
if (CurrentModule == PROLOG_MODULE)
|
|
mod = IDB_MODULE;
|
|
npe = RepPredProp(PredPropByFunc(fe,mod));
|
|
npe->PredFlags |= GoalExPredFlag;
|
|
}
|
|
}
|
|
} else {
|
|
PRED_GOAL_EXPANSION_ALL = TRUE;
|
|
}
|
|
} else {
|
|
if (IsAtomTerm(tm)) {
|
|
if (IsAtomTerm(tg)) {
|
|
PredEntry *p = RepPredProp(PredPropByAtom(AtomOfTerm(tg), tm));
|
|
p->PredFlags |= GoalExPredFlag;
|
|
} else if (IsApplTerm(tg)) {
|
|
PredEntry *p = RepPredProp(PredPropByFunc(FunctorOfTerm(tg), tm));
|
|
p->PredFlags |= GoalExPredFlag;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (mode == consult)
|
|
not_was_reconsulted(p, t, TRUE);
|
|
/* always check if we have a valid error first */
|
|
if (Yap_ErrorMessage && Yap_Error_TYPE == PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE) {
|
|
UNLOCK(p->PELock);
|
|
return TermNil;
|
|
}
|
|
if (pflags & UDIPredFlag) {
|
|
Yap_new_udi_clause(p, cp, t);
|
|
}
|
|
if (!is_dynamic(p)) {
|
|
if (pflags & LogUpdatePredFlag) {
|
|
LogUpdClause *clp = ClauseCodeToLogUpdClause(cp);
|
|
clp->ClFlags |= LogUpdMask;
|
|
if (is_fact(t)) {
|
|
clp->ClFlags |= FactMask;
|
|
clp->ClSource = NULL;
|
|
}
|
|
} else {
|
|
StaticClause *clp = ClauseCodeToStaticClause(cp);
|
|
clp->ClFlags |= StaticMask;
|
|
if (is_fact(t) && !(p->PredFlags & TabledPredFlag)) {
|
|
clp->ClFlags |= FactMask;
|
|
clp->usc.ClPred = p;
|
|
}
|
|
}
|
|
if (compile_mode)
|
|
p->PredFlags = p->PredFlags | CompiledPredFlag;
|
|
else
|
|
p->PredFlags = p->PredFlags | CompiledPredFlag;
|
|
}
|
|
if (p->cs.p_code.FirstClause == NULL) {
|
|
if (!(pflags & DynamicPredFlag)) {
|
|
add_first_static(p, cp, spy_flag);
|
|
/* make sure we have a place to jump to */
|
|
if (p->OpcodeOfPred == UNDEF_OPCODE ||
|
|
p->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
|
|
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
|
|
p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->PredFlags & LogUpdatePredFlag &&
|
|
p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
} else {
|
|
add_first_dynamic(p, cp, spy_flag);
|
|
}
|
|
} else if (mode == asserta) {
|
|
if (pflags & DynamicPredFlag)
|
|
asserta_dynam_clause(p, cp);
|
|
else
|
|
asserta_stat_clause(p, cp, spy_flag);
|
|
} else if (pflags & DynamicPredFlag)
|
|
assertz_dynam_clause(p, cp);
|
|
else {
|
|
assertz_stat_clause(p, cp, spy_flag);
|
|
if (p->OpcodeOfPred != INDEX_OPCODE &&
|
|
p->OpcodeOfPred != Yap_opcode(_spy_pred)) {
|
|
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
|
|
p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (p->PredFlags & LogUpdatePredFlag &&
|
|
p->ModuleOfPred != IDB_MODULE) {
|
|
p->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
}
|
|
UNLOCK(p->PELock);
|
|
if (pflags & LogUpdatePredFlag) {
|
|
LogUpdClause *cl = (LogUpdClause *)ClauseCodeToLogUpdClause(cp);
|
|
tf = MkDBRefTerm((DBRef)cl);
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
INC_CLREF_COUNT(cl);
|
|
#else
|
|
if (!(cl->ClFlags & InUseMask)) {
|
|
cl->ClFlags |= InUseMask;
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
}
|
|
#endif
|
|
} else {
|
|
tf = Yap_MkStaticRefTerm(ClauseCodeToStaticClause(cp));
|
|
}
|
|
if (*t4ref != TermNil) {
|
|
if (!Yap_unify(*t4ref,tf)) {
|
|
return FALSE;
|
|
}
|
|
}
|
|
if (pflags & MultiFileFlag) {
|
|
/* add Info on new clause for multifile predicates to the DB */
|
|
Term t[5], tn;
|
|
t[0] = MkAtomTerm(YapConsultingFile());
|
|
t[1] = MkAtomTerm(at);
|
|
t[2] = MkIntegerTerm(Arity);
|
|
t[3] = mod;
|
|
t[4] = tf;
|
|
tn = Yap_MkApplTerm(FunctorMultiFileClause,5,t);
|
|
Yap_Recordz(AtomMultiFile,tn);
|
|
}
|
|
return TRUE;
|
|
}
|
|
|
|
int
|
|
Yap_addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref) {
|
|
return addclause(t, cp, mode, mod, t4ref);
|
|
}
|
|
|
|
void
|
|
Yap_EraseMegaClause(yamop *cl,PredEntry *ap) {
|
|
/* just make it fail */
|
|
cl->opc = Yap_opcode(_op_fail);
|
|
}
|
|
|
|
void
|
|
Yap_EraseStaticClause(StaticClause *cl, Term mod) {
|
|
PredEntry *ap;
|
|
|
|
/* ok, first I need to find out the parent predicate */
|
|
if (cl->ClFlags & FactMask) {
|
|
ap = cl->usc.ClPred;
|
|
} else {
|
|
Term t = ArgOfTerm(1,cl->usc.ClSource->Entry);
|
|
if (IsAtomTerm(t)) {
|
|
Atom at = AtomOfTerm(t);
|
|
ap = RepPredProp(Yap_GetPredPropByAtom(at, mod));
|
|
} else {
|
|
Functor fun = FunctorOfTerm(t);
|
|
ap = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
|
|
}
|
|
}
|
|
if (ap->PredFlags & MegaClausePredFlag) {
|
|
split_megaclause(ap);
|
|
}
|
|
if (ap->PredFlags & IndexedPredFlag)
|
|
RemoveIndexation(ap);
|
|
ap->cs.p_code.NOfClauses--;
|
|
if (ap->cs.p_code.FirstClause == cl->ClCode) {
|
|
/* got rid of first clause */
|
|
if (ap->cs.p_code.LastClause == cl->ClCode) {
|
|
/* got rid of all clauses */
|
|
ap->cs.p_code.LastClause = ap->cs.p_code.FirstClause = NULL;
|
|
ap->OpcodeOfPred = UNDEF_OPCODE;
|
|
ap->cs.p_code.TrueCodeOfPred =
|
|
(yamop *)(&(ap->OpcodeOfPred));
|
|
} else {
|
|
yamop *ncl = cl->ClNext->ClCode;
|
|
ap->cs.p_code.FirstClause = ncl;
|
|
ap->cs.p_code.TrueCodeOfPred =
|
|
ncl;
|
|
ap->OpcodeOfPred = ncl->opc;
|
|
}
|
|
} else {
|
|
StaticClause *pcl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause),
|
|
*ocl = NULL;
|
|
|
|
while (pcl != cl) {
|
|
ocl = pcl;
|
|
pcl = pcl->ClNext;
|
|
}
|
|
ocl->ClNext = cl->ClNext;
|
|
if (cl->ClCode == ap->cs.p_code.LastClause) {
|
|
ap->cs.p_code.LastClause = ocl->ClCode;
|
|
}
|
|
}
|
|
if (ap->cs.p_code.NOfClauses == 1) {
|
|
ap->cs.p_code.TrueCodeOfPred =
|
|
ap->cs.p_code.FirstClause;
|
|
ap->OpcodeOfPred =
|
|
ap->cs.p_code.TrueCodeOfPred->opc;
|
|
}
|
|
if (cl->ClFlags & HasBlobsMask || static_in_use(ap,TRUE)) {
|
|
LOCK(DeadStaticClausesLock);
|
|
cl->ClNext = DeadStaticClauses;
|
|
DeadStaticClauses = cl;
|
|
UNLOCK(DeadStaticClausesLock);
|
|
} else {
|
|
Yap_InformOfRemoval((CODEADDR)cl);
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
Yap_FreeCodeSpace((char *)cl);
|
|
}
|
|
if (ap->cs.p_code.NOfClauses == 0) {
|
|
ap->CodeOfPred =
|
|
ap->cs.p_code.TrueCodeOfPred;
|
|
} else if (ap->cs.p_code.NOfClauses > 1) {
|
|
ap->OpcodeOfPred = INDEX_OPCODE;
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
} else if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
|
|
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
} else {
|
|
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (ap->PredFlags & LogUpdatePredFlag &&
|
|
ap->ModuleOfPred != IDB_MODULE) {
|
|
ap->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
|
|
}
|
|
#endif
|
|
}
|
|
|
|
void
|
|
Yap_add_logupd_clause(PredEntry *pe, LogUpdClause *cl, int mode) {
|
|
yamop *cp = cl->ClCode;
|
|
|
|
if (pe->PredFlags & IndexedPredFlag) {
|
|
Yap_AddClauseToIndex(pe, cp, mode == asserta);
|
|
}
|
|
if (pe->cs.p_code.FirstClause == NULL) {
|
|
add_first_static(pe, cp, FALSE);
|
|
/* make sure we have a place to jump to */
|
|
if (pe->OpcodeOfPred == UNDEF_OPCODE ||
|
|
pe->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (pe->PredFlags & LogUpdatePredFlag &&
|
|
pe->ModuleOfPred != IDB_MODULE) {
|
|
pe->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
|
|
} else {
|
|
#endif
|
|
pe->CodeOfPred = pe->cs.p_code.TrueCodeOfPred;
|
|
pe->OpcodeOfPred = ((yamop *)(pe->CodeOfPred))->opc;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
}
|
|
#endif
|
|
}
|
|
} else if (mode == asserta) {
|
|
asserta_stat_clause(pe, cp, FALSE);
|
|
} else {
|
|
assertz_stat_clause(pe, cp, FALSE);
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_in_this_f_before(void)
|
|
{ /* '$in_this_file_before'(N,A,M) */
|
|
unsigned int arity;
|
|
Atom at;
|
|
Term t;
|
|
register consult_obj *fp;
|
|
Prop p0;
|
|
Term mod;
|
|
|
|
if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t))
|
|
return (FALSE);
|
|
else
|
|
at = AtomOfTerm(t);
|
|
if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t))
|
|
return (FALSE);
|
|
else
|
|
arity = IntOfTerm(t);
|
|
if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod))
|
|
return FALSE;
|
|
if (arity)
|
|
p0 = PredPropByFunc(Yap_MkFunctor(at, arity), mod);
|
|
else
|
|
p0 = PredPropByAtom(at, mod);
|
|
if (!ConsultSp || ConsultSp == ConsultBase || LastAssertedPred == RepPredProp(p0) || (fp = ConsultSp)->p == p0)
|
|
return FALSE;
|
|
else
|
|
fp++;
|
|
for (; fp < ConsultBase; ++fp)
|
|
if (fp->p == p0)
|
|
break;
|
|
if (fp != ConsultBase)
|
|
return TRUE;
|
|
else
|
|
return FALSE;
|
|
}
|
|
|
|
static Int
|
|
p_first_cl_in_f(void)
|
|
{ /* '$first_cl_in_file'(+N,+Ar,+Mod) */
|
|
unsigned int arity;
|
|
Atom at;
|
|
Term t;
|
|
register consult_obj *fp;
|
|
Prop p0;
|
|
Term mod;
|
|
|
|
|
|
if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t))
|
|
return (FALSE);
|
|
else
|
|
at = AtomOfTerm(t);
|
|
if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t))
|
|
return (FALSE);
|
|
else
|
|
arity = IntOfTerm(t);
|
|
if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod))
|
|
return (FALSE);
|
|
if (arity)
|
|
p0 = PredPropByFunc(Yap_MkFunctor(at, arity),mod);
|
|
else
|
|
p0 = PredPropByAtom(at, mod);
|
|
if (LastAssertedPred == RepPredProp(p0))
|
|
return FALSE;
|
|
if (!ConsultSp)
|
|
return FALSE;
|
|
for (fp = ConsultSp; fp < ConsultBase; ++fp)
|
|
if (fp->p == p0)
|
|
break;
|
|
if (fp != ConsultBase)
|
|
return FALSE;
|
|
return TRUE;
|
|
}
|
|
|
|
#if EMACS
|
|
|
|
/*
|
|
* the place where one would add a new clause for the propriety pred_prop
|
|
*/
|
|
int
|
|
where_new_clause(pred_prop, mode)
|
|
Prop pred_prop;
|
|
int mode;
|
|
{
|
|
PredEntry *p = RepPredProp(pred_prop);
|
|
|
|
if (mode == consult && not_was_reconsulted(p, TermNil, FALSE))
|
|
return (1);
|
|
else
|
|
return (p->cs.p_code.NOfClauses + 1);
|
|
}
|
|
#endif
|
|
|
|
static Int
|
|
p_compile(void)
|
|
{ /* '$compile'(+C,+Flags, Mod) */
|
|
Term t = Deref(ARG1);
|
|
Term t1 = Deref(ARG2);
|
|
Term mod = Deref(ARG4);
|
|
Term tn = TermNil;
|
|
yamop *codeadr;
|
|
|
|
if (IsVarTerm(t1) || !IsIntTerm(t1))
|
|
return (FALSE);
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return (FALSE);
|
|
|
|
YAPEnterCriticalSection();
|
|
codeadr = Yap_cclause(t, 4, mod, Deref(ARG3)); /* vsc: give the number of arguments
|
|
to cclause in case there is overflow */
|
|
t = Deref(ARG1); /* just in case there was an heap overflow */
|
|
if (!Yap_ErrorMessage)
|
|
addclause(t, codeadr, (int) (IntOfTerm(t1) & 3), mod, &tn);
|
|
YAPLeaveCriticalSection();
|
|
if (Yap_ErrorMessage) {
|
|
if (IntOfTerm(t1) & 4) {
|
|
Yap_Error(Yap_Error_TYPE, Yap_Error_Term,
|
|
"in line %d, %s", Yap_FirstLineInParse(), Yap_ErrorMessage);
|
|
} else {
|
|
Yap_Error(Yap_Error_TYPE, Yap_Error_Term, Yap_ErrorMessage);
|
|
}
|
|
return FALSE;
|
|
}
|
|
return TRUE;
|
|
}
|
|
|
|
static Int
|
|
p_compile_dynamic(void)
|
|
{ /* '$compile_dynamic'(+C,+Flags,Mod,-Ref) */
|
|
Term t = Deref(ARG1);
|
|
Term t1 = Deref(ARG2);
|
|
Term mod = Deref(ARG4);
|
|
yamop *code_adr;
|
|
int old_optimize, mode;
|
|
|
|
if (IsVarTerm(t1) || !IsAtomicTerm(t1))
|
|
return FALSE;
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return FALSE;
|
|
if (IsAtomTerm(t1)) {
|
|
if (RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f') mode = asserta;
|
|
else mode = assertz;
|
|
} else mode = IntegerOfTerm(t1);
|
|
old_optimize = optimizer_on;
|
|
optimizer_on = FALSE;
|
|
YAPEnterCriticalSection();
|
|
code_adr = Yap_cclause(t, 5, mod, Deref(ARG3)); /* vsc: give the number of arguments to
|
|
cclause() in case there is a overflow */
|
|
t = Deref(ARG1); /* just in case there was an heap overflow */
|
|
if (!Yap_ErrorMessage) {
|
|
|
|
|
|
optimizer_on = old_optimize;
|
|
addclause(t, code_adr, mode , mod, &ARG5);
|
|
}
|
|
if (Yap_ErrorMessage) {
|
|
if (!Yap_Error_Term)
|
|
Yap_Error_Term = TermNil;
|
|
Yap_Error(Yap_Error_TYPE, Yap_Error_Term, Yap_ErrorMessage);
|
|
YAPLeaveCriticalSection();
|
|
return FALSE;
|
|
}
|
|
YAPLeaveCriticalSection();
|
|
return TRUE;
|
|
}
|
|
|
|
static int consult_level = 0;
|
|
|
|
static Atom
|
|
YapConsultingFile (void)
|
|
{
|
|
if (consult_level == 0) {
|
|
return(AtomUser);
|
|
} else {
|
|
return(Yap_LookupAtom(ConsultBase[2].filename));
|
|
}
|
|
}
|
|
|
|
Atom
|
|
Yap_ConsultingFile (void)
|
|
{
|
|
return YapConsultingFile();
|
|
}
|
|
|
|
/* consult file *file*, *mode* may be one of either consult or reconsult */
|
|
static void
|
|
init_consult(int mode, char *file)
|
|
{
|
|
if (!ConsultSp) {
|
|
InitConsultStack();
|
|
}
|
|
ConsultSp--;
|
|
ConsultSp->filename = file;
|
|
ConsultSp--;
|
|
ConsultSp->mode = mode;
|
|
ConsultSp--;
|
|
ConsultSp->c = (ConsultBase-ConsultSp);
|
|
ConsultBase = ConsultSp;
|
|
#if !defined(YAPOR) && !defined(SBA)
|
|
/* if (consult_level == 0)
|
|
do_toggle_static_predicates_in_use(TRUE); */
|
|
#endif
|
|
consult_level++;
|
|
LastAssertedPred = NULL;
|
|
}
|
|
|
|
void
|
|
Yap_init_consult(int mode, char *file)
|
|
{
|
|
init_consult(mode,file);
|
|
}
|
|
|
|
static Int
|
|
p_startconsult(void)
|
|
{ /* '$start_consult'(+Mode) */
|
|
Term t;
|
|
char *smode = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
|
|
int mode;
|
|
|
|
mode = strcmp("consult",smode);
|
|
init_consult(mode, RepAtom(AtomOfTerm(Deref(ARG2)))->StrOfAE);
|
|
t = MkIntTerm(consult_level);
|
|
return (Yap_unify_constant(ARG3, t));
|
|
}
|
|
|
|
static Int
|
|
p_showconslultlev(void)
|
|
{
|
|
Term t;
|
|
|
|
t = MkIntTerm(consult_level);
|
|
return (Yap_unify_constant(ARG1, t));
|
|
}
|
|
|
|
static void
|
|
end_consult(void)
|
|
{
|
|
ConsultSp = ConsultBase;
|
|
ConsultBase = ConsultSp+ConsultSp->c;
|
|
ConsultSp += 3;
|
|
consult_level--;
|
|
LastAssertedPred = NULL;
|
|
#if !defined(YAPOR) && !defined(SBA)
|
|
/* if (consult_level == 0)
|
|
do_toggle_static_predicates_in_use(FALSE);*/
|
|
#endif
|
|
}
|
|
|
|
void
|
|
Yap_end_consult(void) {
|
|
end_consult();
|
|
}
|
|
|
|
|
|
static Int
|
|
p_endconsult(void)
|
|
{ /* '$end_consult' */
|
|
end_consult();
|
|
return (TRUE);
|
|
}
|
|
|
|
static void
|
|
purge_clauses(PredEntry *pred)
|
|
{
|
|
if (pred->cs.p_code.NOfClauses) {
|
|
if (pred->PredFlags & IndexedPredFlag)
|
|
RemoveIndexation(pred);
|
|
Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
|
|
retract_all(pred, static_in_use(pred,TRUE));
|
|
}
|
|
pred->src.OwnerFile = AtomNil;
|
|
if (pred->PredFlags & MultiFileFlag)
|
|
pred->PredFlags ^= MultiFileFlag;
|
|
}
|
|
|
|
void
|
|
Yap_Abolish(PredEntry *pred)
|
|
{
|
|
purge_clauses(pred);
|
|
}
|
|
|
|
static Int
|
|
p_purge_clauses(void)
|
|
{ /* '$purge_clauses'(+Func) */
|
|
PredEntry *pred;
|
|
Term t = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
|
|
Yap_PutValue(AtomAbol, MkAtomTerm(AtomNil));
|
|
if (IsVarTerm(t))
|
|
return FALSE;
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
|
|
return FALSE;
|
|
}
|
|
if (IsAtomTerm(t)) {
|
|
Atom at = AtomOfTerm(t);
|
|
pred = RepPredProp(PredPropByAtom(at, mod));
|
|
} else if (IsApplTerm(t)) {
|
|
Functor fun = FunctorOfTerm(t);
|
|
pred = RepPredProp(PredPropByFunc(fun, mod));
|
|
} else
|
|
return (FALSE);
|
|
LOCK(pred->PELock);
|
|
if (pred->PredFlags & StandardPredFlag) {
|
|
UNLOCK(pred->PELock);
|
|
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, t, "assert/1");
|
|
return (FALSE);
|
|
}
|
|
purge_clauses(pred);
|
|
UNLOCK(pred->PELock);
|
|
return (TRUE);
|
|
}
|
|
|
|
/******************************************************************
|
|
|
|
MANAGING SPY-POINTS
|
|
|
|
******************************************************************/
|
|
|
|
static Int
|
|
p_setspy(void)
|
|
{ /* '$set_spy'(+Fun,+M) */
|
|
Atom at;
|
|
PredEntry *pred;
|
|
CELL fg;
|
|
Term t, mod;
|
|
|
|
at = AtomSpy;
|
|
pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0));
|
|
SpyCode = pred;
|
|
t = Deref(ARG1);
|
|
mod = Deref(ARG2);
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return (FALSE);
|
|
if (IsVarTerm(t))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t)) {
|
|
Atom at = AtomOfTerm(t);
|
|
pred = RepPredProp(Yap_PredPropByAtomNonThreadLocal(at, mod));
|
|
} else if (IsApplTerm(t)) {
|
|
Functor fun = FunctorOfTerm(t);
|
|
pred = RepPredProp(Yap_PredPropByFunctorNonThreadLocal(fun, mod));
|
|
} else {
|
|
return (FALSE);
|
|
}
|
|
LOCK(pred->PELock);
|
|
restart_spy:
|
|
if (pred->PredFlags & (CPredFlag | SafePredFlag)) {
|
|
UNLOCK(pred->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pred->OpcodeOfPred == UNDEF_OPCODE ||
|
|
pred->OpcodeOfPred == FAIL_OPCODE) {
|
|
UNLOCK(pred->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pred->OpcodeOfPred == INDEX_OPCODE) {
|
|
int i = 0;
|
|
for (i = 0; i < pred->ArityOfPE; i++) {
|
|
XREGS[i+1] = MkVarTerm();
|
|
}
|
|
IPred(pred, 0, CP);
|
|
goto restart_spy;
|
|
}
|
|
fg = pred->PredFlags;
|
|
if (fg & DynamicPredFlag) {
|
|
pred->OpcodeOfPred =
|
|
((yamop *)(pred->CodeOfPred))->opc =
|
|
Yap_opcode(_spy_or_trymark);
|
|
} else {
|
|
pred->OpcodeOfPred = Yap_opcode(_spy_pred);
|
|
pred->CodeOfPred = (yamop *)(&(pred->OpcodeOfPred));
|
|
}
|
|
pred->PredFlags |= SpiedPredFlag;
|
|
UNLOCK(pred->PELock);
|
|
return TRUE;
|
|
}
|
|
|
|
static Int
|
|
p_rmspy(void)
|
|
{ /* '$rm_spy'(+T,+Mod) */
|
|
Atom at;
|
|
PredEntry *pred;
|
|
Term t;
|
|
Term mod;
|
|
|
|
t = Deref(ARG1);
|
|
mod = Deref(ARG2);
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return (FALSE);
|
|
if (IsVarTerm(t))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t)) {
|
|
at = AtomOfTerm(t);
|
|
pred = RepPredProp(Yap_PredPropByAtomNonThreadLocal(at, mod));
|
|
} else if (IsApplTerm(t)) {
|
|
Functor fun = FunctorOfTerm(t);
|
|
pred = RepPredProp(Yap_PredPropByFunctorNonThreadLocal(fun, mod));
|
|
} else
|
|
return FALSE;
|
|
LOCK(pred->PELock);
|
|
if (!(pred->PredFlags & SpiedPredFlag)) {
|
|
UNLOCK(pred->PELock);
|
|
return FALSE;
|
|
}
|
|
#if THREADS
|
|
if (!(pred->PredFlags & ThreadLocalPredFlag)) {
|
|
pred->OpcodeOfPred = Yap_opcode(_thread_local);
|
|
pred->PredFlags ^= SpiedPredFlag;
|
|
UNLOCK(pred->PELock);
|
|
return TRUE;
|
|
}
|
|
#endif
|
|
if (!(pred->PredFlags & (CountPredFlag|ProfiledPredFlag))) {
|
|
if (!(pred->PredFlags & DynamicPredFlag)) {
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (pred->PredFlags & LogUpdatePredFlag &&
|
|
pred->ModuleOfPred != IDB_MODULE) {
|
|
pred->OpcodeOfPred = LOCKPRED_OPCODE;
|
|
pred->CodeOfPred = (yamop *)(&(pred->OpcodeOfPred));
|
|
} else {
|
|
#endif
|
|
pred->CodeOfPred = pred->cs.p_code.TrueCodeOfPred;
|
|
pred->OpcodeOfPred = pred->CodeOfPred->opc;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
}
|
|
#endif
|
|
} else if (pred->OpcodeOfPred == Yap_opcode(_spy_or_trymark)) {
|
|
pred->OpcodeOfPred = Yap_opcode(_try_and_mark);
|
|
} else {
|
|
UNLOCK(pred->PELock);
|
|
return FALSE;
|
|
}
|
|
}
|
|
pred->PredFlags ^= SpiedPredFlag;
|
|
UNLOCK(pred->PELock);
|
|
return (TRUE);
|
|
}
|
|
|
|
|
|
/******************************************************************
|
|
|
|
INFO ABOUT PREDICATES
|
|
|
|
******************************************************************/
|
|
|
|
static Int
|
|
p_number_of_clauses(void)
|
|
{ /* '$number_of_clauses'(Predicate,M,N) */
|
|
Term t = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
int ncl = 0;
|
|
Prop pe;
|
|
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
|
|
return(FALSE);
|
|
}
|
|
if (IsAtomTerm(t)) {
|
|
Atom a = AtomOfTerm(t);
|
|
pe = Yap_GetPredPropByAtom(a, mod);
|
|
} else if (IsApplTerm(t)) {
|
|
register Functor f = FunctorOfTerm(t);
|
|
pe = Yap_GetPredPropByFunc(f, mod);
|
|
} else {
|
|
return (FALSE);
|
|
}
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(RepPredProp(pe)->PELock);
|
|
ncl = RepPredProp(pe)->cs.p_code.NOfClauses;
|
|
UNLOCK(RepPredProp(pe)->PELock);
|
|
return (Yap_unify_constant(ARG3, MkIntegerTerm(ncl)));
|
|
}
|
|
|
|
static Int
|
|
p_in_use(void)
|
|
{ /* '$in_use'(+P,+Mod) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$in_use");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = static_in_use(pe,TRUE);
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_new_multifile(void)
|
|
{ /* '$new_multifile'(+N,+Ar,+Mod) */
|
|
Atom at;
|
|
int arity;
|
|
PredEntry *pe;
|
|
Term t = Deref(ARG1);
|
|
Term mod = Deref(ARG3);
|
|
|
|
if (IsVarTerm(t))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t))
|
|
at = AtomOfTerm(t);
|
|
else
|
|
return (FALSE);
|
|
t = Deref(ARG2);
|
|
if (IsVarTerm(t))
|
|
return (FALSE);
|
|
if (IsIntTerm(t))
|
|
arity = IntOfTerm(t);
|
|
else
|
|
return FALSE;
|
|
if (arity == 0)
|
|
pe = RepPredProp(PredPropByAtom(at, mod));
|
|
else
|
|
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod));
|
|
LOCK(pe->PELock);
|
|
pe->PredFlags |= MultiFileFlag;
|
|
if (pe->ModuleOfPred == PROLOG_MODULE)
|
|
pe->ModuleOfPred = TermProlog;
|
|
if (!(pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
/* static */
|
|
pe->PredFlags |= (SourcePredFlag|CompiledPredFlag);
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
return (TRUE);
|
|
}
|
|
|
|
|
|
static Int
|
|
p_is_multifile(void)
|
|
{ /* '$is_multifile'(+S,+Mod) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_multifile");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & MultiFileFlag);
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_is_log_updatable(void)
|
|
{ /* '$is_dynamic'(+P) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_log_updatable");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & LogUpdatePredFlag);
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_is_source(void)
|
|
{ /* '$is_dynamic'(+P) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & SourcePredFlag);
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_owner_file(void)
|
|
{ /* '$owner_file'(+P,M,F) */
|
|
PredEntry *pe;
|
|
Atom owner;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
if (pe->ModuleOfPred == IDB_MODULE) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->PredFlags & MultiFileFlag) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
owner = pe->src.OwnerFile;
|
|
UNLOCK(pe->PELock);
|
|
return Yap_unify(ARG3, MkAtomTerm(owner));
|
|
}
|
|
|
|
static Int
|
|
p_mk_d(void)
|
|
{ /* '$is_dynamic'(+P) */
|
|
PredEntry *pe;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
if (pe->OpcodeOfPred == UNDEF_OPCODE) {
|
|
pe->OpcodeOfPred = FAIL_OPCODE;
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
return TRUE;
|
|
}
|
|
|
|
static Int
|
|
p_is_dynamic(void)
|
|
{ /* '$is_dynamic'(+P) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_dynamic");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag));
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_is_metapredicate(void)
|
|
{ /* '$is_metapredicate'(+P) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_meta");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & MetaPredFlag);
|
|
UNLOCK(pe->PELock);
|
|
return out;
|
|
}
|
|
|
|
static Int
|
|
p_is_expandgoalormetapredicate(void)
|
|
{ /* '$is_expand_goal_predicate'(+P) */
|
|
PredEntry *pe;
|
|
Term t = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
Int out;
|
|
|
|
if (PRED_GOAL_EXPANSION_ALL)
|
|
return TRUE;
|
|
if (IsVarTerm(t)) {
|
|
return (FALSE);
|
|
} else if (IsAtomTerm(t)) {
|
|
Atom at = AtomOfTerm(t);
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(at, mod));
|
|
if (EndOfPAEntr(pe)) {
|
|
if (PRED_GOAL_EXPANSION_FUNC) {
|
|
Prop p1 = RepAtom(at)->PropsOfAE;
|
|
|
|
while (p1) {
|
|
PredEntry *pe = RepPredProp(p1);
|
|
|
|
if (pe->KindOfPE == PEProp) {
|
|
if (pe->PredFlags & GoalExPredFlag) {
|
|
PredPropByAtom(at, mod);
|
|
return TRUE;
|
|
} else {
|
|
return FALSE;
|
|
}
|
|
}
|
|
p1 = pe->NextOfPE;
|
|
}
|
|
}
|
|
return FALSE;
|
|
}
|
|
} else if (IsApplTerm(t)) {
|
|
Functor fun = FunctorOfTerm(t);
|
|
|
|
if (IsExtensionFunctor(fun)) {
|
|
return FALSE;
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
|
|
if (EndOfPAEntr(pe)) {
|
|
if (PRED_GOAL_EXPANSION_FUNC) {
|
|
FunctorEntry *fe = (FunctorEntry *)fun;
|
|
if (fe->PropsOfFE &&
|
|
(RepPredProp(fe->PropsOfFE)->PredFlags & GoalExPredFlag)) {
|
|
PredPropByFunc(fun, mod);
|
|
return TRUE;
|
|
}
|
|
}
|
|
return FALSE;
|
|
}
|
|
} else {
|
|
return FALSE;
|
|
}
|
|
|
|
LOCK(pe->PELock);
|
|
out = (pe->PredFlags & (GoalExPredFlag|MetaPredFlag));
|
|
UNLOCK(pe->PELock);
|
|
return(out);
|
|
}
|
|
|
|
static Int
|
|
p_pred_exists(void)
|
|
{ /* '$pred_exists'(+P,+M) */
|
|
PredEntry *pe;
|
|
Int out;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "$exists");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
if (pe->PredFlags & HiddenPredFlag){
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
out = (pe->OpcodeOfPred != UNDEF_OPCODE);
|
|
UNLOCK(pe->PELock);
|
|
return out;
|
|
}
|
|
|
|
static Int
|
|
p_set_pred_module(void)
|
|
{ /* '$set_pred_module'(+P,+Mod) */
|
|
PredEntry *pe;
|
|
|
|
pe = get_pred(Deref(ARG1), CurrentModule, "set_pred_module/1");
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
pe->ModuleOfPred = Deref(ARG2);
|
|
UNLOCK(pe->PELock);
|
|
return(TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_undefined(void)
|
|
{ /* '$undefined'(P,Mod) */
|
|
PredEntry *pe;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "undefined/1");
|
|
if (EndOfPAEntr(pe))
|
|
return TRUE;
|
|
LOCK(pe->PELock);
|
|
if (pe->PredFlags & (CPredFlag|UserCPredFlag|TestPredFlag|AsmPredFlag|DynamicPredFlag|LogUpdatePredFlag)) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->OpcodeOfPred == UNDEF_OPCODE) {
|
|
UNLOCK(pe->PELock);
|
|
return TRUE;
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
|
|
/*
|
|
* this predicate should only be called when all clauses for the dynamic
|
|
* predicate were remove, otherwise chaos will follow!!
|
|
*/
|
|
|
|
static Int
|
|
p_kill_dynamic(void)
|
|
{ /* '$kill_dynamic'(P,M) */
|
|
PredEntry *pe;
|
|
|
|
pe = get_pred(Deref(ARG1), Deref(ARG2), "kill_dynamic/1");
|
|
if (EndOfPAEntr(pe))
|
|
return TRUE;
|
|
LOCK(pe->PELock);
|
|
if (!(pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->cs.p_code.LastClause != pe->cs.p_code.FirstClause) {
|
|
UNLOCK(pe->PELock);
|
|
return (FALSE);
|
|
}
|
|
pe->cs.p_code.LastClause = pe->cs.p_code.FirstClause = NULL;
|
|
pe->OpcodeOfPred = UNDEF_OPCODE;
|
|
pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
|
|
pe->PredFlags = pe->PredFlags & GoalExPredFlag;
|
|
UNLOCK(pe->PELock);
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_optimizer_on(void)
|
|
{ /* '$optimizer_on' */
|
|
optimizer_on = TRUE;
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_optimizer_off(void)
|
|
{ /* '$optimizer_off' */
|
|
optimizer_on = FALSE;
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_compile_mode(void)
|
|
{ /* $compile_mode(Old,New) */
|
|
Term t2, t3 = MkIntTerm(compile_mode);
|
|
if (!Yap_unify_constant(ARG1, t3))
|
|
return (FALSE);
|
|
t2 = Deref(ARG2);
|
|
if (IsVarTerm(t2) || !IsIntTerm(t2))
|
|
return (FALSE);
|
|
compile_mode = IntOfTerm(t2) & 1;
|
|
return (TRUE);
|
|
}
|
|
|
|
#if !defined(YAPOR) && !defined(THREADS)
|
|
static yamop *cur_clause(PredEntry *pe, yamop *codeptr)
|
|
{
|
|
StaticClause *cl;
|
|
|
|
cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
|
|
do {
|
|
if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
|
|
return cl->ClCode;
|
|
}
|
|
if (cl->ClCode == pe->cs.p_code.LastClause)
|
|
break;
|
|
cl = cl->ClNext;
|
|
} while (TRUE);
|
|
Yap_Error(SYSTEM_ERROR,TermNil,"could not find clause for indexing code");
|
|
return(NULL);
|
|
}
|
|
|
|
static yamop *cur_log_upd_clause(PredEntry *pe, yamop *codeptr)
|
|
{
|
|
LogUpdClause *cl;
|
|
cl = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
|
|
do {
|
|
if (IN_BLOCK(codeptr,cl->ClCode,cl->ClSize)) {
|
|
return((yamop *)cl->ClCode);
|
|
}
|
|
cl = cl->ClNext;
|
|
} while (cl != NULL);
|
|
Yap_Error(SYSTEM_ERROR,TermNil,"could not find clause for indexing code");
|
|
return(NULL);
|
|
}
|
|
|
|
static Int
|
|
search_for_static_predicate_in_use(PredEntry *p, int check_everything)
|
|
{
|
|
choiceptr b_ptr = B;
|
|
CELL *env_ptr = ENV;
|
|
|
|
if (check_everything && P) {
|
|
PredEntry *pe = EnvPreg(P);
|
|
if (p == pe) return TRUE;
|
|
pe = EnvPreg(CP);
|
|
if (p == pe) return TRUE;
|
|
}
|
|
do {
|
|
PredEntry *pe;
|
|
|
|
/* check first environments that are younger than our latest choicepoint */
|
|
if (check_everything && env_ptr) {
|
|
/*
|
|
I do not need to check environments for asserts,
|
|
only for retracts
|
|
*/
|
|
while (env_ptr && b_ptr > (choiceptr)env_ptr) {
|
|
PredEntry *pe = EnvPreg((yamop *)env_ptr[E_CP]);
|
|
if (p == pe) return(TRUE);
|
|
if (env_ptr != NULL)
|
|
env_ptr = (CELL *)(env_ptr[E_E]);
|
|
}
|
|
}
|
|
/* now mark the choicepoint */
|
|
|
|
if (b_ptr)
|
|
pe = PredForChoicePt(b_ptr->cp_ap);
|
|
else
|
|
return FALSE;
|
|
if (pe == p) {
|
|
if (check_everything)
|
|
return TRUE;
|
|
LOCK(pe->PELock);
|
|
if (p->PredFlags & IndexedPredFlag) {
|
|
yamop *code_p = b_ptr->cp_ap;
|
|
yamop *code_beg = p->cs.p_code.TrueCodeOfPred;
|
|
|
|
/* FIX ME */
|
|
|
|
if (p->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
|
|
if (find_owner_log_index(cl, code_p))
|
|
b_ptr->cp_ap = cur_log_upd_clause(pe, b_ptr->cp_ap->u.Otapl.d);
|
|
} else if (p->PredFlags & MegaClausePredFlag) {
|
|
StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
|
|
if (find_owner_static_index(cl, code_p))
|
|
b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.Otapl.d);
|
|
} else {
|
|
/* static clause */
|
|
StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
|
|
if (find_owner_static_index(cl, code_p)) {
|
|
b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.Otapl.d);
|
|
}
|
|
}
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
}
|
|
env_ptr = b_ptr->cp_env;
|
|
b_ptr = b_ptr->cp_b;
|
|
} while (b_ptr != NULL);
|
|
return(FALSE);
|
|
}
|
|
|
|
static void
|
|
mark_pred(int mark, PredEntry *pe)
|
|
{
|
|
/* if the predicate is static mark it */
|
|
if (pe->ModuleOfPred) {
|
|
LOCK(pe->PELock);
|
|
if (mark) {
|
|
pe->PredFlags |= InUsePredFlag;
|
|
} else {
|
|
pe->PredFlags &= ~InUsePredFlag;
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
}
|
|
}
|
|
|
|
/* go up the chain of choice_points and environments,
|
|
marking all static predicates that current execution is depending
|
|
upon */
|
|
static void
|
|
do_toggle_static_predicates_in_use(int mask)
|
|
{
|
|
choiceptr b_ptr = B;
|
|
CELL *env_ptr = ENV;
|
|
|
|
if (b_ptr == NULL)
|
|
return;
|
|
|
|
do {
|
|
PredEntry *pe;
|
|
/* check first environments that are younger than our latest choicepoint */
|
|
while (b_ptr > (choiceptr)env_ptr) {
|
|
PredEntry *pe = EnvPreg((yamop *)env_ptr[E_CP]);
|
|
|
|
mark_pred(mask, pe);
|
|
env_ptr = (CELL *)(env_ptr[E_E]);
|
|
}
|
|
/* now mark the choicepoint */
|
|
if ((b_ptr)) {
|
|
if ((pe = PredForChoicePt(b_ptr->cp_ap))) {
|
|
mark_pred(mask, pe);
|
|
}
|
|
}
|
|
env_ptr = b_ptr->cp_env;
|
|
b_ptr = b_ptr->cp_b;
|
|
} while (b_ptr != NULL);
|
|
/* mark or unmark all predicates */
|
|
STATIC_PREDICATES_MARKED = mask;
|
|
}
|
|
|
|
#endif /* !defined(YAPOR) && !defined(THREADS) */
|
|
|
|
static LogUpdIndex *
|
|
find_owner_log_index(LogUpdIndex *cl, yamop *code_p)
|
|
{
|
|
yamop *code_beg = cl->ClCode;
|
|
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
|
|
|
if (code_p >= code_beg && code_p <= code_end) {
|
|
return cl;
|
|
}
|
|
cl = cl->ChildIndex;
|
|
while (cl != NULL) {
|
|
LogUpdIndex *out;
|
|
if ((out = find_owner_log_index(cl, code_p)) != NULL) {
|
|
return out;
|
|
}
|
|
cl = cl->SiblingIndex;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static StaticIndex *
|
|
find_owner_static_index(StaticIndex *cl, yamop *code_p)
|
|
{
|
|
yamop *code_beg = cl->ClCode;
|
|
yamop *code_end = (yamop *)((char *)cl + cl->ClSize);
|
|
|
|
if (code_p >= code_beg && code_p <= code_end) {
|
|
return cl;
|
|
}
|
|
cl = cl->ChildIndex;
|
|
while (cl != NULL) {
|
|
StaticIndex *out;
|
|
if ((out = find_owner_static_index(cl, code_p)) != NULL) {
|
|
return out;
|
|
}
|
|
cl = cl->SiblingIndex;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
ClauseUnion *
|
|
Yap_find_owner_index(yamop *ipc, PredEntry *ap)
|
|
{
|
|
/* we assume we have an owner index */
|
|
if (ap->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred);
|
|
return (ClauseUnion *)find_owner_log_index(cl,ipc);
|
|
} else {
|
|
StaticIndex *cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
|
|
return (ClauseUnion *)find_owner_static_index(cl,ipc);
|
|
}
|
|
}
|
|
|
|
static Term
|
|
all_envs(CELL *env_ptr)
|
|
{
|
|
Term tf = AbsPair(H);
|
|
CELL *bp = NULL;
|
|
|
|
/* walk the environment chain */
|
|
while (env_ptr != NULL) {
|
|
bp = H;
|
|
H += 2;
|
|
/* notice that MkIntegerTerm may increase the Heap */
|
|
bp[0] = MkIntegerTerm(LCL0-env_ptr);
|
|
if (H >= ASP) {
|
|
bp[1] = TermNil;
|
|
return tf;
|
|
} else {
|
|
bp[1] = AbsPair(H);
|
|
}
|
|
env_ptr = (CELL *)(env_ptr[E_E]);
|
|
}
|
|
bp[1] = TermNil;
|
|
return tf;
|
|
}
|
|
|
|
static Term
|
|
all_cps(choiceptr b_ptr)
|
|
{
|
|
CELL *bp = NULL;
|
|
Term tf = AbsPair(H);
|
|
|
|
while (b_ptr != NULL) {
|
|
bp = H;
|
|
H += 2;
|
|
/* notice that MkIntegerTerm may increase the Heap */
|
|
bp[0] = MkIntegerTerm((Int)(LCL0-(CELL *)b_ptr));
|
|
if (H >= ASP) {
|
|
bp[1] = TermNil;
|
|
return tf;
|
|
} else {
|
|
bp[1] = AbsPair(H);
|
|
}
|
|
b_ptr = b_ptr->cp_b;
|
|
}
|
|
bp[1] = TermNil;
|
|
return tf;
|
|
}
|
|
|
|
|
|
static Term
|
|
all_calls(void)
|
|
{
|
|
Term ts[4];
|
|
Functor f = Yap_MkFunctor(AtomLocal,4);
|
|
|
|
ts[0] = MkIntegerTerm((Int)P);
|
|
ts[1] = MkIntegerTerm((Int)CP);
|
|
if (yap_flags[STACK_DUMP_ON_ERROR_FLAG]) {
|
|
ts[2] = all_envs(ENV);
|
|
ts[3] = all_cps(B);
|
|
} else {
|
|
ts[2] = ts[3] = TermNil;
|
|
}
|
|
return Yap_MkApplTerm(f,4,ts);
|
|
}
|
|
|
|
Term
|
|
Yap_all_calls(void)
|
|
{
|
|
return all_calls();
|
|
}
|
|
|
|
static Int
|
|
p_all_choicepoints(void)
|
|
{
|
|
return Yap_unify(ARG1,all_cps(B));
|
|
}
|
|
|
|
static Int
|
|
p_all_envs(void)
|
|
{
|
|
return Yap_unify(ARG1,all_envs(ENV));
|
|
}
|
|
|
|
static Int
|
|
p_current_stack(void)
|
|
{
|
|
#ifdef YAPOR
|
|
return(FALSE);
|
|
#else
|
|
return(Yap_unify(ARG1,all_calls()));
|
|
#endif
|
|
}
|
|
|
|
/* This predicate is to be used by reconsult to mark all predicates
|
|
currently in use as being executed.
|
|
|
|
The idea is to go up the chain of choice_points and environments.
|
|
|
|
*/
|
|
static Int
|
|
p_toggle_static_predicates_in_use(void)
|
|
{
|
|
#if !defined(YAPOR) && !defined(THREADS)
|
|
Term t = Deref(ARG1);
|
|
Int mask;
|
|
|
|
/* find out whether we need to mark or unmark */
|
|
if (IsVarTerm(t)) {
|
|
Yap_Error(INSTANTIATION_ERROR,t,"toggle_static_predicates_in_use/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(t)) {
|
|
Yap_Error(TYPE_ERROR_INTEGER,t,"toggle_static_predicates_in_use/1");
|
|
return(FALSE);
|
|
} else {
|
|
mask = IntOfTerm(t);
|
|
}
|
|
do_toggle_static_predicates_in_use(mask);
|
|
#endif
|
|
return TRUE;
|
|
}
|
|
|
|
static void
|
|
clause_was_found(PredEntry *pp, Atom *pat, UInt *parity) {
|
|
if (pp->ModuleOfPred == IDB_MODULE) {
|
|
if (pp->PredFlags & NumberDBPredFlag) {
|
|
*parity = 0;
|
|
*pat = AtomInteger;
|
|
} else if (pp->PredFlags & AtomDBPredFlag) {
|
|
*parity = 0;
|
|
*pat = (Atom)pp->FunctorOfPred;
|
|
} else {
|
|
*pat = NameOfFunctor(pp->FunctorOfPred);
|
|
*parity = ArityOfFunctor(pp->FunctorOfPred);
|
|
}
|
|
} else {
|
|
*parity = pp->ArityOfPE;
|
|
if (pp->ArityOfPE) {
|
|
*pat = NameOfFunctor(pp->FunctorOfPred);
|
|
} else {
|
|
*pat = (Atom)(pp->FunctorOfPred);
|
|
}
|
|
}
|
|
}
|
|
|
|
static void
|
|
code_in_pred_info(PredEntry *pp, Atom *pat, UInt *parity) {
|
|
clause_was_found(pp, pat, parity);
|
|
}
|
|
|
|
static int
|
|
code_in_pred_lu_index(LogUpdIndex *icl, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
|
|
LogUpdIndex *cicl;
|
|
if (IN_BLOCK(codeptr,icl,icl->ClSize)) {
|
|
if (startp) *startp = (CODEADDR)icl;
|
|
if (endp) *endp = (CODEADDR)icl+icl->ClSize;
|
|
return TRUE;
|
|
}
|
|
cicl = icl->ChildIndex;
|
|
while (cicl != NULL) {
|
|
if (code_in_pred_lu_index(cicl, codeptr, startp, endp))
|
|
return TRUE;
|
|
cicl = cicl->SiblingIndex;
|
|
}
|
|
return FALSE;
|
|
}
|
|
|
|
static int
|
|
code_in_pred_s_index(StaticIndex *icl, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
|
|
StaticIndex *cicl;
|
|
if (IN_BLOCK(codeptr,icl,icl->ClSize)) {
|
|
if (startp) *startp = (CODEADDR)icl;
|
|
if (endp) *endp = (CODEADDR)icl+icl->ClSize;
|
|
return TRUE;
|
|
}
|
|
cicl = icl->ChildIndex;
|
|
while (cicl != NULL) {
|
|
if (code_in_pred_s_index(cicl, codeptr, startp, endp))
|
|
return TRUE;
|
|
cicl = cicl->SiblingIndex;
|
|
}
|
|
return FALSE;
|
|
}
|
|
|
|
static Int
|
|
find_code_in_clause(PredEntry *pp, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
|
|
Int i = 1;
|
|
yamop *clcode;
|
|
|
|
clcode = pp->cs.p_code.FirstClause;
|
|
if (clcode != NULL) {
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
|
|
do {
|
|
if (IN_BLOCK(codeptr,(CODEADDR)cl,cl->ClSize)) {
|
|
if (startp)
|
|
*startp = (CODEADDR)cl;
|
|
if (endp)
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return i;
|
|
}
|
|
i++;
|
|
cl = cl->ClNext;
|
|
} while (cl != NULL);
|
|
} else if (pp->PredFlags & DynamicPredFlag) {
|
|
do {
|
|
DynamicClause *cl;
|
|
|
|
cl = ClauseCodeToDynamicClause(clcode);
|
|
if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
|
|
if (startp)
|
|
*startp = (CODEADDR)cl;
|
|
if (endp)
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return i;
|
|
}
|
|
if (clcode == pp->cs.p_code.LastClause)
|
|
break;
|
|
i++;
|
|
clcode = NextDynamicClause(clcode);
|
|
} while (TRUE);
|
|
} else if (pp->PredFlags & MegaClausePredFlag) {
|
|
MegaClause *cl;
|
|
|
|
cl = ClauseCodeToMegaClause(clcode);
|
|
if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
|
|
if (startp)
|
|
*startp = (CODEADDR)cl;
|
|
if (endp)
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return 1+((char *)codeptr-(char *)cl->ClCode)/cl->ClItemSize;
|
|
}
|
|
} else {
|
|
StaticClause *cl;
|
|
|
|
cl = ClauseCodeToStaticClause(clcode);
|
|
do {
|
|
if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
|
|
if (startp)
|
|
*startp = (CODEADDR)cl;
|
|
if (endp)
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return i;
|
|
}
|
|
if (cl->ClCode == pp->cs.p_code.LastClause)
|
|
break;
|
|
i++;
|
|
cl = cl->ClNext;
|
|
} while (TRUE);
|
|
}
|
|
}
|
|
return(0);
|
|
}
|
|
|
|
static int
|
|
cl_code_in_pred(PredEntry *pp, yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
|
|
Int out;
|
|
|
|
LOCK(pp->PELock);
|
|
/* check if the codeptr comes from the indexing code */
|
|
if (pp->PredFlags & IndexedPredFlag) {
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
if (code_in_pred_lu_index(ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, startp, endp)) {
|
|
UNLOCK(pp->PELock);
|
|
return TRUE;
|
|
}
|
|
} else {
|
|
if (code_in_pred_s_index(ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, startp, endp)) {
|
|
UNLOCK(pp->PELock);
|
|
return TRUE;
|
|
}
|
|
}
|
|
}
|
|
if (pp->PredFlags & (CPredFlag|AsmPredFlag|UserCPredFlag)) {
|
|
StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
|
|
if (IN_BLOCK(codeptr,(CODEADDR)cl,cl->ClSize)) {
|
|
if (startp)
|
|
*startp = (CODEADDR)cl;
|
|
if (endp)
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
UNLOCK(pp->PELock);
|
|
return TRUE;
|
|
} else {
|
|
UNLOCK(pp->PELock);
|
|
return FALSE;
|
|
}
|
|
} else {
|
|
out = find_code_in_clause(pp, codeptr, startp, endp);
|
|
}
|
|
UNLOCK(pp->PELock);
|
|
if (out) return TRUE;
|
|
return FALSE;
|
|
}
|
|
|
|
static Int
|
|
code_in_pred(PredEntry *pp, Atom *pat, UInt *parity, yamop *codeptr) {
|
|
Int out;
|
|
|
|
LOCK(pp->PELock);
|
|
/* check if the codeptr comes from the indexing code */
|
|
if (pp->PredFlags & IndexedPredFlag) {
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
if (code_in_pred_lu_index(ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, NULL, NULL)) {
|
|
code_in_pred_info(pp, pat, parity);
|
|
UNLOCK(pp->PELock);
|
|
return -1;
|
|
}
|
|
} else {
|
|
if (code_in_pred_s_index(ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr, NULL, NULL)) {
|
|
code_in_pred_info(pp, pat, parity);
|
|
UNLOCK(pp->PELock);
|
|
return -1;
|
|
}
|
|
}
|
|
}
|
|
if ((out = find_code_in_clause(pp, codeptr, NULL, NULL))) {
|
|
clause_was_found(pp, pat, parity);
|
|
}
|
|
UNLOCK(pp->PELock);
|
|
return out;
|
|
}
|
|
|
|
static Int
|
|
PredForCode(yamop *codeptr, Atom *pat, UInt *parity, Term *pmodule) {
|
|
Int found = 0;
|
|
ModEntry *me = CurrentModules;
|
|
|
|
/* should we allow the user to see hidden predicates? */
|
|
while (me) {
|
|
|
|
PredEntry *pp;
|
|
pp = me->PredForME;
|
|
while (pp != NULL) {
|
|
if ((found = code_in_pred(pp, pat, parity, codeptr)) != 0) {
|
|
*pmodule = MkAtomTerm(me->AtomOfME);
|
|
return found;
|
|
}
|
|
pp = pp->NextPredOfModule;
|
|
}
|
|
me = me->NextME;
|
|
}
|
|
return(0);
|
|
}
|
|
|
|
Int
|
|
Yap_PredForCode(yamop *codeptr, find_pred_type where_from, Atom *pat, UInt *parity, Term *pmodule) {
|
|
PredEntry *p;
|
|
|
|
if (where_from == FIND_PRED_FROM_CP) {
|
|
p = PredForChoicePt(codeptr);
|
|
} else if (where_from == FIND_PRED_FROM_ENV) {
|
|
p = EnvPreg(codeptr);
|
|
if (p) {
|
|
Int out;
|
|
if (p->ModuleOfPred == PROLOG_MODULE)
|
|
*pmodule = TermProlog;
|
|
else
|
|
*pmodule = p->ModuleOfPred;
|
|
out = find_code_in_clause(p, codeptr, NULL, NULL);
|
|
clause_was_found(p, pat, parity);
|
|
return out;
|
|
}
|
|
} else {
|
|
return PredForCode(codeptr, pat, parity, pmodule);
|
|
}
|
|
if (p == NULL) {
|
|
return 0;
|
|
}
|
|
clause_was_found(p, pat, parity);
|
|
if (p->ModuleOfPred == PROLOG_MODULE)
|
|
*pmodule = TermProlog;
|
|
else
|
|
*pmodule = p->ModuleOfPred;
|
|
return -1;
|
|
}
|
|
|
|
/* intruction blocks we found ourselves at */
|
|
static PredEntry *
|
|
walk_got_lu_block(LogUpdIndex *cl, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
PredEntry *pp = cl->ClPred;
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return pp;
|
|
}
|
|
|
|
/* intruction blocks we found ourselves at */
|
|
static PredEntry *
|
|
walk_got_lu_clause(LogUpdClause *cl, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return cl->ClPred;
|
|
}
|
|
|
|
/* we hit a meta-call, so we don't know what is happening */
|
|
static PredEntry *
|
|
found_meta_call(CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
PredEntry *pp = PredMetaCall;
|
|
*startp = (CODEADDR)&(pp->OpcodeOfPred);
|
|
*endp = (CODEADDR)NEXTOP((yamop *)&(pp->OpcodeOfPred),e);
|
|
return pp;
|
|
}
|
|
|
|
/* intruction blocks we found ourselves at */
|
|
static PredEntry *
|
|
walk_found_c_pred(PredEntry *pp, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
|
|
*startp = (CODEADDR)&(cl->ClCode);
|
|
*endp = (CODEADDR)&(cl->ClCode)+cl->ClSize;
|
|
return pp;
|
|
}
|
|
|
|
/* we hit a mega-clause, no point in going on */
|
|
static PredEntry *
|
|
found_mega_clause(PredEntry *pp, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
|
|
*startp = (CODEADDR)mcl;
|
|
*endp = (CODEADDR)mcl+mcl->ClSize;
|
|
return pp;
|
|
}
|
|
|
|
/* we hit a mega-clause, no point in going on */
|
|
static PredEntry *
|
|
found_idb_clause(yamop *pc, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(pc);
|
|
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
return cl->ClPred;
|
|
}
|
|
|
|
/* we hit a expand_index, no point in going on */
|
|
static PredEntry *
|
|
found_expand_index(yamop *pc, CODEADDR *startp, CODEADDR *endp, yamop *codeptr)
|
|
{
|
|
PredEntry *pp = codeptr->u.sssllp.p;
|
|
if (pc == codeptr) {
|
|
*startp = (CODEADDR)codeptr;
|
|
*endp = (CODEADDR)NEXTOP(codeptr,sssllp);
|
|
}
|
|
return pp;
|
|
}
|
|
|
|
/* we hit a expand_index, no point in going on */
|
|
static PredEntry *
|
|
found_fail(yamop *pc, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
PredEntry *pp = RepPredProp(Yap_GetPredPropByAtom(AtomFail,CurrentModule));
|
|
*startp = *endp = (CODEADDR)FAILCODE;
|
|
return pp;
|
|
}
|
|
|
|
/* we hit a expand_index, no point in going on */
|
|
static PredEntry *
|
|
found_owner_op(yamop *pc, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
PredEntry *pp = ((PredEntry *)(Unsigned(pc)-(CELL)(&(((PredEntry *)NULL)->OpcodeOfPred))));
|
|
*startp = (CODEADDR)&(pp->OpcodeOfPred);
|
|
*endp = (CODEADDR)NEXTOP((yamop *)&(pp->OpcodeOfPred),e);
|
|
return pp;
|
|
}
|
|
|
|
/* we hit a expand_index, no point in going on */
|
|
static PredEntry *
|
|
found_expand(yamop *pc, CODEADDR *startp, CODEADDR *endp)
|
|
{
|
|
PredEntry *pp = ((PredEntry *)(Unsigned(pc)-(CELL)(&(((PredEntry *)NULL)->cs.p_code.ExpandCode))));
|
|
*startp = (CODEADDR)&(pp->cs.p_code.ExpandCode);
|
|
*endp = (CODEADDR)NEXTOP((yamop *)&(pp->cs.p_code.ExpandCode),e);
|
|
return pp;
|
|
}
|
|
|
|
static PredEntry *
|
|
found_ystop(yamop *pc, int clause_code, CODEADDR *startp, CODEADDR *endp, PredEntry *pp)
|
|
{
|
|
if (pc == YESCODE) {
|
|
pp = RepPredProp(Yap_GetPredPropByAtom(AtomTrue,CurrentModule));
|
|
*startp = (CODEADDR)YESCODE;
|
|
*endp = (CODEADDR)YESCODE+(CELL)(NEXTOP((yamop *)NULL,e));
|
|
return pp;
|
|
}
|
|
if (!pp) {
|
|
/* must be an index */
|
|
PredEntry **pep = (PredEntry **)pc->u.l.l;
|
|
pp = pep[-1];
|
|
}
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
if (clause_code) {
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(pc->u.l.l);
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
} else {
|
|
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(pc->u.l.l);
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
}
|
|
} else if (pp->PredFlags & DynamicPredFlag) {
|
|
DynamicClause *cl = ClauseCodeToDynamicClause(pc->u.l.l);
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
} else {
|
|
if (clause_code) {
|
|
StaticClause *cl = ClauseCodeToStaticClause(pc->u.l.l);
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
} else {
|
|
StaticIndex *cl = ClauseCodeToStaticIndex(pc->u.l.l);
|
|
*startp = (CODEADDR)cl;
|
|
*endp = (CODEADDR)cl+cl->ClSize;
|
|
}
|
|
}
|
|
return pp;
|
|
}
|
|
|
|
static PredEntry *
|
|
ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
|
|
yamop *pc;
|
|
PredEntry *pp = NULL;
|
|
int clause_code = FALSE;
|
|
|
|
if (codeptr >= COMMA_CODE &&
|
|
codeptr < FAILCODE) {
|
|
pp = RepPredProp(Yap_GetPredPropByFunc(FunctorComma,CurrentModule));
|
|
*startp = (CODEADDR)COMMA_CODE;
|
|
*endp = (CODEADDR)(FAILCODE-1);
|
|
return pp;
|
|
}
|
|
pc = codeptr;
|
|
#include "walkclause.h"
|
|
return NULL;
|
|
}
|
|
|
|
PredEntry *
|
|
Yap_PredEntryForCode(yamop *codeptr, find_pred_type where_from, CODEADDR *startp, CODEADDR *endp) {
|
|
|
|
if (where_from == FIND_PRED_FROM_CP) {
|
|
PredEntry *pp = PredForChoicePt(codeptr);
|
|
if (cl_code_in_pred(pp, codeptr, startp, endp)) {
|
|
return pp;
|
|
}
|
|
} else if (where_from == FIND_PRED_FROM_ENV) {
|
|
PredEntry *pp = EnvPreg(codeptr);
|
|
if (cl_code_in_pred(pp, codeptr, startp, endp)) {
|
|
return pp;
|
|
}
|
|
} else {
|
|
return ClauseInfoForCode(codeptr, startp, endp);
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
|
|
static Int
|
|
p_pred_for_code(void) {
|
|
yamop *codeptr;
|
|
Atom at;
|
|
UInt arity;
|
|
Term tmodule = TermProlog;
|
|
Int cl;
|
|
Term t = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t)) {
|
|
return FALSE;
|
|
} else if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorStaticClause) {
|
|
codeptr = Yap_ClauseFromTerm(t)->ClCode;
|
|
} else if (IsIntegerTerm(t)) {
|
|
codeptr = (yamop *)IntegerOfTerm(t);
|
|
} else if (IsDBRefTerm(t)) {
|
|
codeptr = (yamop *)DBRefOfTerm(t);
|
|
} else {
|
|
return FALSE;
|
|
}
|
|
cl = PredForCode(codeptr, &at, &arity, &tmodule);
|
|
if (!tmodule) tmodule = TermProlog;
|
|
if (cl == 0) {
|
|
return Yap_unify(ARG5,MkIntTerm(0));
|
|
} else {
|
|
return(Yap_unify(ARG2,MkAtomTerm(at)) &&
|
|
Yap_unify(ARG3,MkIntegerTerm(arity)) &&
|
|
Yap_unify(ARG4,tmodule) &&
|
|
Yap_unify(ARG5,MkIntegerTerm(cl)));
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_is_profiled(void)
|
|
{
|
|
Term t = Deref(ARG1);
|
|
char *s;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Term ta;
|
|
|
|
if (PROFILING) ta = MkAtomTerm(AtomOn);
|
|
else ta = MkAtomTerm(AtomOff);
|
|
BIND((CELL *)t,ta,bind_is_profiled);
|
|
#ifdef COROUTINING
|
|
DO_TRAIL(VarOfTerm(t), ta);
|
|
if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
|
|
bind_is_profiled:
|
|
#endif
|
|
return(TRUE);
|
|
} else if (!IsAtomTerm(t)) return(FALSE);
|
|
s = RepAtom(AtomOfTerm(t))->StrOfAE;
|
|
if (strcmp(s,"on") == 0) {
|
|
PROFILING = TRUE;
|
|
Yap_InitComma();
|
|
return(TRUE);
|
|
} else if (strcmp(s,"off") == 0) {
|
|
PROFILING = FALSE;
|
|
Yap_InitComma();
|
|
return(TRUE);
|
|
}
|
|
return(FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_profile_info(void)
|
|
{
|
|
Term mod = Deref(ARG1);
|
|
Term tfun = Deref(ARG2);
|
|
Term out;
|
|
PredEntry *pe;
|
|
Term p[3];
|
|
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return(FALSE);
|
|
if (IsVarTerm(tfun)) {
|
|
return(FALSE);
|
|
} else if (IsApplTerm(tfun)) {
|
|
Functor f = FunctorOfTerm(tfun);
|
|
if (IsExtensionFunctor(f)) {
|
|
return(FALSE);
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
|
|
} else if (IsAtomTerm(tfun)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
|
|
} else {
|
|
return(FALSE);
|
|
}
|
|
if (EndOfPAEntr(pe))
|
|
return(FALSE);
|
|
LOCK(pe->StatisticsForPred.lock);
|
|
if (!(pe->StatisticsForPred.NOfEntries)) {
|
|
UNLOCK(pe->StatisticsForPred.lock);
|
|
return(FALSE);
|
|
}
|
|
p[0] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfEntries);
|
|
p[1] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfHeadSuccesses);
|
|
p[2] = Yap_MkULLIntTerm(pe->StatisticsForPred.NOfRetries);
|
|
UNLOCK(pe->StatisticsForPred.lock);
|
|
out = Yap_MkApplTerm(Yap_MkFunctor(AtomProfile,3),3,p);
|
|
return(Yap_unify(ARG3,out));
|
|
}
|
|
|
|
static Int
|
|
p_profile_reset(void)
|
|
{
|
|
Term mod = Deref(ARG1);
|
|
Term tfun = Deref(ARG2);
|
|
PredEntry *pe;
|
|
|
|
if (IsVarTerm(mod) || !IsAtomTerm(mod))
|
|
return(FALSE);
|
|
if (IsVarTerm(tfun)) {
|
|
return(FALSE);
|
|
} else if (IsApplTerm(tfun)) {
|
|
Functor f = FunctorOfTerm(tfun);
|
|
if (IsExtensionFunctor(f)) {
|
|
return(FALSE);
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
|
|
} else if (IsAtomTerm(tfun)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
|
|
} else {
|
|
return(FALSE);
|
|
}
|
|
if (EndOfPAEntr(pe))
|
|
return(FALSE);
|
|
LOCK(pe->StatisticsForPred.lock);
|
|
pe->StatisticsForPred.NOfEntries = 0;
|
|
pe->StatisticsForPred.NOfHeadSuccesses = 0;
|
|
pe->StatisticsForPred.NOfRetries = 0;
|
|
UNLOCK(pe->StatisticsForPred.lock);
|
|
return(TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_is_call_counted(void)
|
|
{
|
|
Term t = Deref(ARG1);
|
|
char *s;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Term ta;
|
|
|
|
if (CALL_COUNTING) ta = MkAtomTerm(AtomOn);
|
|
else ta = MkAtomTerm(AtomOff);
|
|
BIND((CELL *)t,ta,bind_is_call_counted);
|
|
#ifdef COROUTINING
|
|
DO_TRAIL(VarOfTerm(t), ta);
|
|
if (IsAttVar(VarOfTerm(t))) Yap_WakeUp((CELL *)t);
|
|
bind_is_call_counted:
|
|
#endif
|
|
return(TRUE);
|
|
} else if (!IsAtomTerm(t)) return(FALSE);
|
|
s = RepAtom(AtomOfTerm(t))->StrOfAE;
|
|
if (strcmp(s,"on") == 0) {
|
|
CALL_COUNTING = TRUE;
|
|
Yap_InitComma();
|
|
return(TRUE);
|
|
} else if (strcmp(s,"off") == 0) {
|
|
CALL_COUNTING = FALSE;
|
|
Yap_InitComma();
|
|
return(TRUE);
|
|
}
|
|
return(FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_call_count_info(void)
|
|
{
|
|
return(Yap_unify(MkIntegerTerm(ReductionsCounter),ARG1) &&
|
|
Yap_unify(MkIntegerTerm(PredEntriesCounter),ARG2) &&
|
|
Yap_unify(MkIntegerTerm(PredEntriesCounter),ARG3));
|
|
}
|
|
|
|
static Int
|
|
p_call_count_reset(void)
|
|
{
|
|
ReductionsCounter = 0;
|
|
ReductionsCounterOn = FALSE;
|
|
PredEntriesCounter = 0;
|
|
PredEntriesCounterOn = FALSE;
|
|
RetriesCounter = 0;
|
|
RetriesCounterOn = FALSE;
|
|
return(TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_call_count_set(void)
|
|
{
|
|
int do_calls = IntOfTerm(ARG2);
|
|
int do_retries = IntOfTerm(ARG4);
|
|
int do_entries = IntOfTerm(ARG6);
|
|
|
|
if (do_calls)
|
|
ReductionsCounter = IntegerOfTerm(Deref(ARG1));
|
|
ReductionsCounterOn = do_calls;
|
|
if (do_retries)
|
|
RetriesCounter = IntegerOfTerm(Deref(ARG3));
|
|
RetriesCounterOn = do_retries;
|
|
if (do_entries)
|
|
PredEntriesCounter = IntegerOfTerm(Deref(ARG5));
|
|
PredEntriesCounterOn = do_entries;
|
|
return(TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_clean_up_dead_clauses(void)
|
|
{
|
|
while (DeadStaticClauses != NULL) {
|
|
char *pt = (char *)DeadStaticClauses;
|
|
Yap_ClauseSpace -= DeadStaticClauses->ClSize;
|
|
DeadStaticClauses = DeadStaticClauses->ClNext;
|
|
Yap_InformOfRemoval((CODEADDR)pt);
|
|
Yap_FreeCodeSpace(pt);
|
|
}
|
|
while (DeadStaticIndices != NULL) {
|
|
char *pt = (char *)DeadStaticIndices;
|
|
if (DeadStaticIndices->ClFlags & SwitchTableMask)
|
|
Yap_IndexSpace_SW -= DeadStaticIndices->ClSize;
|
|
else
|
|
Yap_IndexSpace_Tree -= DeadStaticIndices->ClSize;
|
|
DeadStaticIndices = DeadStaticIndices->SiblingIndex;
|
|
Yap_InformOfRemoval((CODEADDR)pt);
|
|
Yap_FreeCodeSpace(pt);
|
|
}
|
|
while (DeadMegaClauses != NULL) {
|
|
char *pt = (char *)DeadMegaClauses;
|
|
Yap_ClauseSpace -= DeadMegaClauses->ClSize;
|
|
DeadMegaClauses = DeadMegaClauses->ClNext;
|
|
Yap_InformOfRemoval((CODEADDR)pt);
|
|
Yap_FreeCodeSpace(pt);
|
|
}
|
|
return TRUE;
|
|
}
|
|
|
|
static Int /* $parent_pred(Module, Name, Arity) */
|
|
p_parent_pred(void)
|
|
{
|
|
/* This predicate is called from the debugger.
|
|
We assume a sequence of the form a -> b */
|
|
Atom at;
|
|
UInt arity;
|
|
Term module;
|
|
if (!PredForCode(P_before_spy, &at, &arity, &module)) {
|
|
return(Yap_unify(ARG1, MkIntTerm(0)) &&
|
|
Yap_unify(ARG2, MkAtomTerm(AtomMetaCall)) &&
|
|
Yap_unify(ARG3, MkIntTerm(0)));
|
|
}
|
|
return(Yap_unify(ARG1, MkIntTerm(module)) &&
|
|
Yap_unify(ARG2, MkAtomTerm(at)) &&
|
|
Yap_unify(ARG3, MkIntTerm(arity)));
|
|
}
|
|
|
|
static Int /* $system_predicate(P) */
|
|
p_system_pred(void)
|
|
{
|
|
PredEntry *pe;
|
|
|
|
Term t1 = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
|
|
restart_system_pred:
|
|
if (IsVarTerm(t1))
|
|
return FALSE;
|
|
if (IsAtomTerm(t1)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor funt = FunctorOfTerm(t1);
|
|
if (IsExtensionFunctor(funt)) {
|
|
return FALSE;
|
|
}
|
|
if (funt == FunctorModule) {
|
|
Term nmod = ArgOfTerm(1, t1);
|
|
if (IsVarTerm(nmod)) {
|
|
Yap_Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
|
|
return FALSE;
|
|
}
|
|
if (!IsAtomTerm(nmod)) {
|
|
Yap_Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
|
|
return FALSE;
|
|
}
|
|
t1 = ArgOfTerm(2, t1);
|
|
goto restart_system_pred;
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
|
|
} else if (IsPairTerm(t1)) {
|
|
return TRUE;
|
|
} else
|
|
return FALSE;
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
return(!pe->ModuleOfPred || /* any predicate in prolog module */
|
|
/* any C-pred */
|
|
pe->PredFlags & (UserCPredFlag|CPredFlag|BinaryPredFlag|AsmPredFlag|TestPredFlag) ||
|
|
/* any weird user built-in */
|
|
pe->OpcodeOfPred == Yap_opcode(_try_userc));
|
|
}
|
|
|
|
static Int /* $system_predicate(P) */
|
|
p_all_system_pred(void)
|
|
{
|
|
PredEntry *pe;
|
|
|
|
Term t1 = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
|
|
restart_system_pred:
|
|
if (IsVarTerm(t1))
|
|
return TRUE;
|
|
if (IsAtomTerm(t1)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor funt = FunctorOfTerm(t1);
|
|
if (IsExtensionFunctor(funt)) {
|
|
return FALSE;
|
|
}
|
|
if (funt == FunctorModule) {
|
|
Term nmod = ArgOfTerm(1, t1);
|
|
if (IsVarTerm(nmod)) {
|
|
Yap_Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
|
|
return FALSE;
|
|
}
|
|
if (!IsAtomTerm(nmod)) {
|
|
Yap_Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
|
|
return FALSE;
|
|
}
|
|
t1 = ArgOfTerm(2, t1);
|
|
goto restart_system_pred;
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
|
|
} else if (IsPairTerm(t1)) {
|
|
return TRUE;
|
|
} else
|
|
return FALSE;
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
if (pe->ModuleOfPred) {
|
|
if (!Yap_unify(ARG3,pe->ModuleOfPred))
|
|
return FALSE;
|
|
} else {
|
|
if (!Yap_unify(ARG3,TermProlog))
|
|
return FALSE;
|
|
}
|
|
return(!pe->ModuleOfPred || /* any predicate in prolog module */
|
|
/* any C-pred */
|
|
pe->PredFlags & (UserCPredFlag|CPredFlag|BinaryPredFlag|AsmPredFlag|TestPredFlag) ||
|
|
/* any weird user built-in */
|
|
pe->OpcodeOfPred == Yap_opcode(_try_userc));
|
|
}
|
|
|
|
static Int /* $system_predicate(P) */
|
|
p_hide_predicate(void)
|
|
{
|
|
PredEntry *pe;
|
|
|
|
Term t1 = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
|
|
restart_system_pred:
|
|
if (IsVarTerm(t1))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t1)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor funt = FunctorOfTerm(t1);
|
|
if (IsExtensionFunctor(funt)) {
|
|
return(FALSE);
|
|
}
|
|
if (funt == FunctorModule) {
|
|
Term nmod = ArgOfTerm(1, t1);
|
|
if (IsVarTerm(nmod)) {
|
|
Yap_Error(INSTANTIATION_ERROR,ARG1,"hide_predicate/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(nmod)) {
|
|
Yap_Error(TYPE_ERROR_ATOM,ARG1,"hide_predicate/1");
|
|
return(FALSE);
|
|
}
|
|
t1 = ArgOfTerm(2, t1);
|
|
goto restart_system_pred;
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
|
|
} else if (IsPairTerm(t1)) {
|
|
return (TRUE);
|
|
} else
|
|
return (FALSE);
|
|
if (EndOfPAEntr(pe))
|
|
return FALSE;
|
|
pe->PredFlags |= HiddenPredFlag;
|
|
return(TRUE);
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_hidden_predicate(void)
|
|
{
|
|
PredEntry *pe;
|
|
|
|
Term t1 = Deref(ARG1);
|
|
Term mod = Deref(ARG2);
|
|
|
|
restart_system_pred:
|
|
if (IsVarTerm(t1))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t1)) {
|
|
pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor funt = FunctorOfTerm(t1);
|
|
if (IsExtensionFunctor(funt)) {
|
|
return(FALSE);
|
|
}
|
|
if (funt == FunctorModule) {
|
|
Term nmod = ArgOfTerm(1, t1);
|
|
if (IsVarTerm(nmod)) {
|
|
Yap_Error(INSTANTIATION_ERROR,ARG1,"hide_predicate/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(nmod)) {
|
|
Yap_Error(TYPE_ERROR_ATOM,ARG1,"hide_predicate/1");
|
|
return(FALSE);
|
|
}
|
|
t1 = ArgOfTerm(2, t1);
|
|
goto restart_system_pred;
|
|
}
|
|
pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
|
|
} else if (IsPairTerm(t1)) {
|
|
return (TRUE);
|
|
} else
|
|
return (FALSE);
|
|
if (EndOfPAEntr(pe))
|
|
return(FALSE);
|
|
return(pe->PredFlags & HiddenPredFlag);
|
|
}
|
|
|
|
static Int
|
|
fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
|
|
{
|
|
LogUpdClause *cl;
|
|
Term rtn;
|
|
Term Terms[3];
|
|
|
|
Terms[0] = th;
|
|
Terms[1] = tb;
|
|
Terms[2] = tr;
|
|
cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClause->CodeOfPred,Otapl), cp_ptr);
|
|
th = Terms[0];
|
|
tb = Terms[1];
|
|
tr = Terms[2];
|
|
/* don't do this!! I might have stored a choice-point and changed ASP
|
|
Yap_RecoverSlots(3);
|
|
*/
|
|
if (cl == NULL) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
rtn = MkDBRefTerm((DBRef)cl);
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
INC_CLREF_COUNT(cl);
|
|
#else
|
|
if (!(cl->ClFlags & InUseMask)) {
|
|
cl->ClFlags |= InUseMask;
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
}
|
|
#endif
|
|
if (cl->ClFlags & FactMask) {
|
|
if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
|
|
!Yap_unify(tr, rtn)) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->ArityOfPE) {
|
|
Functor f = FunctorOfTerm(th);
|
|
UInt arity = ArityOfFunctor(f), i;
|
|
CELL *pt = RepAppl(th)+1;
|
|
|
|
for (i=0; i<arity; i++) {
|
|
XREGS[i+1] = pt[i];
|
|
}
|
|
/* don't need no ENV */
|
|
if (first_time &&
|
|
P->opc != EXECUTE_CPRED_OP_CODE) {
|
|
CP = P;
|
|
ENV = YENV;
|
|
YENV = ASP;
|
|
YENV[E_CB] = (CELL) B;
|
|
|
|
}
|
|
P = cl->ClCode;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
PP = pe;
|
|
#endif
|
|
} else {
|
|
/* we don't actually need to execute code */
|
|
UNLOCK(pe->PELock);
|
|
}
|
|
return TRUE;
|
|
} else {
|
|
Term t;
|
|
|
|
while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
|
|
if (first_time) {
|
|
ARG5 = th;
|
|
ARG6 = tb;
|
|
ARG7 = tr;
|
|
if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
if (!Yap_growglobal(NULL)) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
} else {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
if (!Yap_gcl(Yap_Error_Size, 7, ENV, gc_P(P,CP))) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
}
|
|
th = ARG5;
|
|
tb = ARG6;
|
|
tr = ARG7;
|
|
} else {
|
|
ARG6 = th;
|
|
ARG7 = tb;
|
|
ARG8 = tr;
|
|
if (!Yap_gcl(Yap_Error_Size, 8, ENV, gc_P(P,CP))) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
th = ARG6;
|
|
tb = ARG7;
|
|
tr = ARG8;
|
|
}
|
|
}
|
|
UNLOCK(pe->PELock);
|
|
return(Yap_unify(th, ArgOfTerm(1,t)) &&
|
|
Yap_unify(tb, ArgOfTerm(2,t)) &&
|
|
Yap_unify(tr, rtn));
|
|
}
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_log_update_clause(void)
|
|
{
|
|
PredEntry *pe;
|
|
Term t1 = Deref(ARG1);
|
|
Int ret;
|
|
yamop *new_cp;
|
|
|
|
if (P->opc == EXECUTE_CPRED_OP_CODE) {
|
|
new_cp = CP;
|
|
} else {
|
|
new_cp = P;
|
|
}
|
|
pe = get_pred(t1, Deref(ARG2), "clause/3");
|
|
if (pe == NULL || EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
ret = fetch_next_lu_clause(pe, pe->CodeOfPred, t1, ARG3, ARG4, new_cp, TRUE);
|
|
return ret;
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_continue_log_update_clause(void)
|
|
{
|
|
PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
|
|
yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
|
|
|
|
LOCK(pe->PELock);
|
|
return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
|
|
}
|
|
|
|
static Int
|
|
fetch_next_lu_clause_erase(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
|
|
{
|
|
LogUpdClause *cl;
|
|
Term rtn;
|
|
Term Terms[3];
|
|
|
|
Terms[0] = th;
|
|
Terms[1] = tb;
|
|
Terms[2] = tr;
|
|
cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClauseErase->CodeOfPred,Otapl), cp_ptr);
|
|
th = Terms[0];
|
|
tb = Terms[1];
|
|
tr = Terms[2];
|
|
/* don't do this!! I might have stored a choice-point and changed ASP
|
|
Yap_RecoverSlots(3);
|
|
*/
|
|
if (cl == NULL) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
rtn = MkDBRefTerm((DBRef)cl);
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
INC_CLREF_COUNT(cl);
|
|
#else
|
|
if (!(cl->ClFlags & InUseMask)) {
|
|
cl->ClFlags |= InUseMask;
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
}
|
|
#endif
|
|
if (cl->ClFlags & FactMask) {
|
|
if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
|
|
!Yap_unify(tr, rtn)) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->ArityOfPE) {
|
|
Functor f = FunctorOfTerm(th);
|
|
UInt arity = ArityOfFunctor(f), i;
|
|
CELL *pt = RepAppl(th)+1;
|
|
|
|
for (i=0; i<arity; i++) {
|
|
XREGS[i+1] = pt[i];
|
|
}
|
|
/* don't need no ENV */
|
|
if (first_time &&
|
|
P->opc != EXECUTE_CPRED_OP_CODE) {
|
|
CP = P;
|
|
ENV = YENV;
|
|
YENV = ASP;
|
|
YENV[E_CB] = (CELL) B;
|
|
}
|
|
P = cl->ClCode;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
PP = pe;
|
|
#endif
|
|
} else {
|
|
/* we don't actually need to execute code */
|
|
UNLOCK(pe->PELock);
|
|
}
|
|
Yap_ErLogUpdCl(cl);
|
|
return TRUE;
|
|
} else {
|
|
Term t;
|
|
Int res;
|
|
|
|
while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
|
|
if (first_time) {
|
|
ARG5 = th;
|
|
ARG6 = tb;
|
|
ARG7 = tr;
|
|
if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
if (!Yap_growglobal(NULL)) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
} else {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
if (!Yap_gcl(Yap_Error_Size, 7, ENV, gc_P(P,CP))) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
}
|
|
th = ARG5;
|
|
tb = ARG6;
|
|
tr = ARG7;
|
|
} else {
|
|
ARG6 = th;
|
|
ARG7 = tb;
|
|
ARG8 = tr;
|
|
if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
|
|
UNLOCK(pe->PELock);
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
th = ARG6;
|
|
tb = ARG7;
|
|
tr = ARG8;
|
|
}
|
|
}
|
|
res = Yap_unify(th, ArgOfTerm(1,t)) &&
|
|
Yap_unify(tb, ArgOfTerm(2,t)) &&
|
|
Yap_unify(tr, rtn);
|
|
if (res)
|
|
Yap_ErLogUpdCl(cl);
|
|
UNLOCK(pe->PELock);
|
|
return res;
|
|
}
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_log_update_clause_erase(void)
|
|
{
|
|
PredEntry *pe;
|
|
Term t1 = Deref(ARG1);
|
|
Int ret;
|
|
yamop *new_cp;
|
|
|
|
if (P->opc == EXECUTE_CPRED_OP_CODE) {
|
|
new_cp = CP;
|
|
} else {
|
|
new_cp = P;
|
|
}
|
|
pe = get_pred(t1, Deref(ARG2), "clause/3");
|
|
if (pe == NULL || EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
ret = fetch_next_lu_clause_erase(pe, pe->CodeOfPred, t1, ARG3, ARG4, new_cp, TRUE);
|
|
return ret;
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_continue_log_update_clause_erase(void)
|
|
{
|
|
PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
|
|
yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
|
|
|
|
LOCK(pe->PELock);
|
|
return fetch_next_lu_clause_erase(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
|
|
}
|
|
|
|
static void
|
|
adjust_cl_timestamp(LogUpdClause *cl, UInt *arp, UInt *base)
|
|
{
|
|
UInt clstamp = cl->ClTimeEnd;
|
|
if (cl->ClTimeEnd != TIMESTAMP_EOT) {
|
|
while (arp[0] > clstamp)
|
|
arp--;
|
|
if (arp[0] == clstamp) {
|
|
cl->ClTimeEnd = (arp-base);
|
|
} else {
|
|
cl->ClTimeEnd = (arp-base)+1;
|
|
}
|
|
}
|
|
clstamp = cl->ClTimeStart;
|
|
while (arp[0] > clstamp)
|
|
arp--;
|
|
if (arp[0] == clstamp) {
|
|
cl->ClTimeStart = (arp-base);
|
|
} else {
|
|
cl->ClTimeStart = (arp-base)+1;
|
|
}
|
|
clstamp = cl->ClTimeEnd;
|
|
}
|
|
|
|
|
|
static Term
|
|
replace_integer(Term orig, UInt new)
|
|
{
|
|
CELL *pt;
|
|
|
|
if (IntInBnd((Int)new))
|
|
return MkIntTerm(new);
|
|
/* should create an old integer */
|
|
if (!IsApplTerm(orig)) {
|
|
Yap_Error(SYSTEM_ERROR,orig,"%uld-->%uld where it should increase",(unsigned long int)IntegerOfTerm(orig),(unsigned long int)new);
|
|
return MkIntegerTerm(new);
|
|
}
|
|
/* appl->appl */
|
|
/* replace integer in situ */
|
|
pt = RepAppl(orig)+1;
|
|
*pt = new;
|
|
return orig;
|
|
}
|
|
|
|
void /* $hidden_predicate(P) */
|
|
Yap_UpdateTimestamps(PredEntry *ap)
|
|
{
|
|
choiceptr bptr = B;
|
|
yamop *cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,Otapl);
|
|
yamop *cl = NEXTOP(PredLogUpdClause->CodeOfPred,Otapl);
|
|
yamop *cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,Otapl);
|
|
UInt ar = ap->ArityOfPE;
|
|
UInt *arp, *top, *base;
|
|
LogUpdClause *lcl;
|
|
|
|
#if THREADS
|
|
Yap_Error(SYSTEM_ERROR,TermNil,"Timestamp overflow %p", ap);
|
|
return;
|
|
#endif
|
|
if (!ap->cs.p_code.NOfClauses)
|
|
return;
|
|
restart:
|
|
*--ASP = TIMESTAMP_EOT;
|
|
top = arp = (UInt *)ASP;
|
|
while (bptr) {
|
|
op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
|
|
|
|
switch (opnum) {
|
|
case _retry_logical:
|
|
case _count_retry_logical:
|
|
case _profiled_retry_logical:
|
|
case _trust_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_trust_logical:
|
|
if (bptr->cp_ap->u.OtaLl.d->ClPred == ap) {
|
|
UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
|
|
if (ts != arp[0]) {
|
|
if (arp-H < 1024) {
|
|
goto overflow;
|
|
}
|
|
/* be thrifty, have this in case there is a hole */
|
|
if (ts != arp[0]-1) {
|
|
UInt x = arp[0];
|
|
*--arp = x;
|
|
}
|
|
*--arp = ts;
|
|
}
|
|
}
|
|
bptr = bptr->cp_b;
|
|
break;
|
|
case _retry:
|
|
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
|
|
((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
|
|
UInt ts = IntegerOfTerm(bptr->cp_args[5]);
|
|
if (ts != arp[0]) {
|
|
if (arp-H < 1024) {
|
|
goto overflow;
|
|
}
|
|
if (ts != arp[0]-1) {
|
|
UInt x = arp[0];
|
|
*--arp = x;
|
|
}
|
|
*--arp = ts;
|
|
}
|
|
}
|
|
bptr = bptr->cp_b;
|
|
break;
|
|
default:
|
|
bptr = bptr->cp_b;
|
|
continue;
|
|
}
|
|
}
|
|
if (*arp)
|
|
*--arp = 0L;
|
|
base = arp;
|
|
lcl = ClauseCodeToLogUpdClause(ap->cs.p_code.FirstClause);
|
|
while (lcl) {
|
|
adjust_cl_timestamp(lcl, top-1, base);
|
|
lcl = lcl->ClNext;
|
|
}
|
|
lcl = DBErasedList;
|
|
while (lcl) {
|
|
if (lcl->ClPred == ap)
|
|
adjust_cl_timestamp(lcl, top-1, base);
|
|
lcl = lcl->ClNext;
|
|
}
|
|
arp = top-1;
|
|
bptr = B;
|
|
while (bptr) {
|
|
op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
|
|
|
|
switch (opnum) {
|
|
case _retry_logical:
|
|
case _count_retry_logical:
|
|
case _profiled_retry_logical:
|
|
case _trust_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_trust_logical:
|
|
if (bptr->cp_ap->u.OtaLl.d->ClPred == ap) {
|
|
UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
|
|
while (ts != arp[0])
|
|
arp--;
|
|
bptr->cp_args[ar] = replace_integer(bptr->cp_args[ar], arp-base);
|
|
}
|
|
bptr = bptr->cp_b;
|
|
break;
|
|
case _retry:
|
|
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
|
|
((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
|
|
UInt ts = IntegerOfTerm(bptr->cp_args[5]);
|
|
while (ts != arp[0])
|
|
arp--;
|
|
bptr->cp_args[5] = replace_integer(bptr->cp_args[5], arp-base);
|
|
}
|
|
bptr = bptr->cp_b;
|
|
break;
|
|
default:
|
|
bptr = bptr->cp_b;
|
|
continue;
|
|
}
|
|
}
|
|
return;
|
|
overflow:
|
|
if (!Yap_growstack(64*1024)) {
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return;
|
|
}
|
|
goto restart;
|
|
}
|
|
|
|
static Int
|
|
fetch_next_static_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
|
|
{
|
|
StaticClause *cl;
|
|
Term rtn;
|
|
Term Terms[3];
|
|
|
|
Terms[0] = th;
|
|
Terms[1] = tb;
|
|
Terms[2] = tr;
|
|
cl = (StaticClause *)Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredStaticClause->CodeOfPred,Otapl), cp_ptr);
|
|
UNLOCK(pe->PELock);
|
|
th = Deref(Terms[0]);
|
|
tb = Deref(Terms[1]);
|
|
tr = Deref(Terms[2]);
|
|
/* don't do this!! I might have stored a choice-point and changed ASP
|
|
Yap_RecoverSlots(3);
|
|
*/
|
|
if (cl == NULL)
|
|
return FALSE;
|
|
if (pe->PredFlags & MegaClausePredFlag) {
|
|
yamop *code = (yamop *)cl;
|
|
rtn = Yap_MkMegaRefTerm(pe,code);
|
|
if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
|
|
!Yap_unify(tr, rtn))
|
|
return FALSE;
|
|
if (pe->ArityOfPE) {
|
|
Functor f = FunctorOfTerm(th);
|
|
UInt arity = ArityOfFunctor(f), i;
|
|
CELL *pt = RepAppl(th)+1;
|
|
|
|
for (i=0; i<arity; i++) {
|
|
XREGS[i+1] = pt[i];
|
|
}
|
|
/* don't need no ENV */
|
|
if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
|
|
CP = P;
|
|
ENV = YENV;
|
|
YENV = ASP;
|
|
YENV[E_CB] = (CELL) B;
|
|
}
|
|
P = code;
|
|
}
|
|
return TRUE;
|
|
}
|
|
rtn = Yap_MkStaticRefTerm(cl);
|
|
if (cl->ClFlags & FactMask) {
|
|
if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
|
|
!Yap_unify(tr, rtn))
|
|
return FALSE;
|
|
|
|
if (pe->ArityOfPE) {
|
|
Functor f = FunctorOfTerm(th);
|
|
UInt arity = ArityOfFunctor(f), i;
|
|
CELL *pt = RepAppl(th)+1;
|
|
|
|
for (i=0; i<arity; i++) {
|
|
XREGS[i+1] = pt[i];
|
|
}
|
|
/* don't need no ENV */
|
|
if (first_time &&
|
|
P->opc != EXECUTE_CPRED_OP_CODE) {
|
|
CP = P;
|
|
ENV = YENV;
|
|
YENV = ASP;
|
|
YENV[E_CB] = (CELL) B;
|
|
}
|
|
P = cl->ClCode;
|
|
}
|
|
return TRUE;
|
|
} else {
|
|
Term t;
|
|
|
|
if (!(pe->PredFlags & SourcePredFlag)) {
|
|
/* no source */
|
|
rtn = Yap_MkStaticRefTerm(cl);
|
|
return Yap_unify(tr, rtn);
|
|
}
|
|
|
|
if (!(pe->PredFlags & SourcePredFlag)) {
|
|
rtn = Yap_MkStaticRefTerm(cl);
|
|
return Yap_unify(tr, rtn);
|
|
}
|
|
while ((t = Yap_FetchTermFromDB(cl->usc.ClSource)) == 0L) {
|
|
if (first_time) {
|
|
if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
if (!Yap_growglobal(NULL)) {
|
|
Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
} else {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
ARG5 = th;
|
|
ARG6 = tb;
|
|
ARG7 = tr;
|
|
if (!Yap_gc(7, ENV, gc_P(P,CP))) {
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
th = ARG5;
|
|
tb = ARG6;
|
|
tr = ARG7;
|
|
}
|
|
} else {
|
|
Yap_Error_TYPE = YAP_NO_ERROR;
|
|
ARG6 = th;
|
|
ARG7 = tb;
|
|
ARG8 = tr;
|
|
if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
|
|
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
|
|
return FALSE;
|
|
}
|
|
th = ARG6;
|
|
tb = ARG7;
|
|
tr = ARG8;
|
|
}
|
|
}
|
|
rtn = Yap_MkStaticRefTerm(cl);
|
|
if (!IsApplTerm(t) || FunctorOfTerm(t) != FunctorAssert) {
|
|
return(Yap_unify(th, t) &&
|
|
Yap_unify(tb, MkAtomTerm(AtomTrue)) &&
|
|
Yap_unify(tr, rtn));
|
|
} else {
|
|
return(Yap_unify(th, ArgOfTerm(1,t)) &&
|
|
Yap_unify(tb, ArgOfTerm(2,t)) &&
|
|
Yap_unify(tr, rtn));
|
|
}
|
|
}
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_static_clause(void)
|
|
{
|
|
PredEntry *pe;
|
|
Term t1 = Deref(ARG1);
|
|
yamop * new_cp;
|
|
|
|
if (P->opc == EXECUTE_CPRED_OP_CODE) {
|
|
new_cp = CP;
|
|
} else {
|
|
new_cp = P;
|
|
}
|
|
pe = get_pred(t1, Deref(ARG2), "clause/3");
|
|
if (pe == NULL || EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
return fetch_next_static_clause(pe, pe->CodeOfPred, ARG1, ARG3, ARG4, new_cp, TRUE);
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_nth_clause(void)
|
|
{
|
|
PredEntry *pe;
|
|
Term t1 = Deref(ARG1);
|
|
Term tn = Deref(ARG3);
|
|
LogUpdClause *cl;
|
|
Int ncls;
|
|
|
|
if (!IsIntegerTerm(tn))
|
|
return FALSE;
|
|
ncls = IntegerOfTerm(tn);
|
|
pe = get_pred(t1, Deref(ARG2), "clause/3");
|
|
if (pe == NULL || EndOfPAEntr(pe))
|
|
return FALSE;
|
|
LOCK(pe->PELock);
|
|
if (!(pe->PredFlags & (SourcePredFlag|LogUpdatePredFlag))) {
|
|
return FALSE;
|
|
}
|
|
/* in case we have to index or to expand code */
|
|
if (pe->ModuleOfPred != IDB_MODULE) {
|
|
UInt i;
|
|
|
|
for (i = 1; i <= pe->ArityOfPE; i++) {
|
|
XREGS[i] = MkVarTerm();
|
|
}
|
|
} else {
|
|
XREGS[2] = MkVarTerm();
|
|
}
|
|
if(pe->OpcodeOfPred == INDEX_OPCODE) {
|
|
IPred(pe, 0, CP);
|
|
}
|
|
cl = Yap_NthClause(pe, ncls);
|
|
if (cl == NULL) {
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
if (pe->PredFlags & LogUpdatePredFlag) {
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
INC_CLREF_COUNT(cl);
|
|
#else
|
|
if (!(cl->ClFlags & InUseMask)) {
|
|
cl->ClFlags |= InUseMask;
|
|
TRAIL_CLREF(cl); /* So that fail will erase it */
|
|
}
|
|
#endif
|
|
UNLOCK(pe->PELock);
|
|
return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
|
|
} else if (pe->PredFlags & MegaClausePredFlag) {
|
|
UNLOCK(pe->PELock);
|
|
return Yap_unify(Yap_MkMegaRefTerm(pe,(yamop *)cl), ARG4);
|
|
} else {
|
|
UNLOCK(pe->PELock);
|
|
return Yap_unify(Yap_MkStaticRefTerm((StaticClause *)cl), ARG4);
|
|
}
|
|
}
|
|
|
|
static Int /* $hidden_predicate(P) */
|
|
p_continue_static_clause(void)
|
|
{
|
|
PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
|
|
yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
|
|
|
|
LOCK(pe->PELock);
|
|
return fetch_next_static_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_ap, FALSE);
|
|
}
|
|
|
|
#if LOW_PROF
|
|
|
|
static void
|
|
add_code_in_pred(PredEntry *pp) {
|
|
yamop *clcode;
|
|
|
|
LOCK(pp->PELock);
|
|
/* check if the codeptr comes from the indexing code */
|
|
|
|
/* highly likely this is used for indexing */
|
|
Yap_inform_profiler_of_clause((yamop *)&(pp->OpcodeOfPred), (yamop *)(&(pp->OpcodeOfPred)+1), pp, 1);
|
|
if (pp->PredFlags & (CPredFlag|AsmPredFlag)) {
|
|
char *code_end;
|
|
StaticClause *cl;
|
|
|
|
clcode = pp->CodeOfPred;
|
|
cl = ClauseCodeToStaticClause(clcode);
|
|
code_end = (char *)cl + cl->ClSize;
|
|
Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0);
|
|
UNLOCK(pp->PELock);
|
|
return;
|
|
}
|
|
Yap_inform_profiler_of_clause((yamop *)&(pp->cs.p_code.ExpandCode), (yamop *)(&(pp->cs.p_code.ExpandCode)+1), pp, 1);
|
|
clcode = pp->cs.p_code.TrueCodeOfPred;
|
|
if (pp->PredFlags & IndexedPredFlag) {
|
|
char *code_end;
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(clcode);
|
|
code_end = (char *)cl + cl->ClSize;
|
|
} else {
|
|
StaticIndex *cl = ClauseCodeToStaticIndex(clcode);
|
|
code_end = (char *)cl + cl->ClSize;
|
|
}
|
|
Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0);
|
|
}
|
|
clcode = pp->cs.p_code.FirstClause;
|
|
if (clcode != NULL) {
|
|
if (pp->PredFlags & LogUpdatePredFlag) {
|
|
LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
|
|
do {
|
|
char *code_end;
|
|
|
|
code_end = (char *)cl + cl->ClSize;
|
|
Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
|
|
cl = cl->ClNext;
|
|
} while (cl != NULL);
|
|
} else if (pp->PredFlags & DynamicPredFlag) {
|
|
do {
|
|
DynamicClause *cl;
|
|
CODEADDR code_end;
|
|
|
|
cl = ClauseCodeToDynamicClause(clcode);
|
|
code_end = (CODEADDR)cl + cl->ClSize;
|
|
Yap_inform_profiler_of_clause(clcode, (yamop *)code_end, pp,0);
|
|
if (clcode == pp->cs.p_code.LastClause)
|
|
break;
|
|
clcode = NextDynamicClause(clcode);
|
|
} while (TRUE);
|
|
} else {
|
|
StaticClause *cl = ClauseCodeToStaticClause(clcode);
|
|
do {
|
|
char *code_end;
|
|
|
|
code_end = (char *)cl + cl->ClSize;
|
|
Yap_inform_profiler_of_clause(cl->ClCode, (yamop *)code_end, pp,0);
|
|
if (cl->ClCode == pp->cs.p_code.FirstClause)
|
|
break;
|
|
cl = cl->ClNext;
|
|
} while (TRUE);
|
|
}
|
|
}
|
|
UNLOCK(pp->PELock);
|
|
}
|
|
|
|
|
|
void
|
|
Yap_dump_code_area_for_profiler(void) {
|
|
ModEntry *me = CurrentModules;
|
|
|
|
while (me) {
|
|
PredEntry *pp = me->PredForME;
|
|
|
|
while (pp != NULL) {
|
|
/* if (pp->ArityOfPE) {
|
|
fprintf(stderr,"%s/%d %p\n",
|
|
RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE,
|
|
pp->ArityOfPE,
|
|
pp);
|
|
} else {
|
|
fprintf(stderr,"%s %p\n",
|
|
RepAtom((Atom)(pp->FunctorOfPred))->StrOfAE,
|
|
pp);
|
|
}*/
|
|
add_code_in_pred(pp);
|
|
pp = pp->NextPredOfModule;
|
|
}
|
|
me = me->NextME;
|
|
}
|
|
Yap_inform_profiler_of_clause(COMMA_CODE, FAILCODE, RepPredProp(Yap_GetPredPropByFunc(FunctorComma,0)),0);
|
|
Yap_inform_profiler_of_clause(FAILCODE, FAILCODE+1, RepPredProp(Yap_GetPredPropByAtom(AtomFail,0)),0);
|
|
}
|
|
|
|
#endif /* LOW_PROF */
|
|
|
|
static UInt
|
|
index_ssz(StaticIndex *x)
|
|
{
|
|
UInt sz = x->ClSize;
|
|
x = x->ChildIndex;
|
|
while (x != NULL) {
|
|
sz += index_ssz(x);
|
|
x = x->SiblingIndex;
|
|
}
|
|
return sz;
|
|
}
|
|
|
|
static Int
|
|
static_statistics(PredEntry *pe)
|
|
{
|
|
UInt sz = 0, cls = 0, isz = 0;
|
|
StaticClause *cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
|
|
|
|
if (pe->cs.p_code.NOfClauses > 1 &&
|
|
pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause) {
|
|
isz = index_ssz(ClauseCodeToStaticIndex(pe->cs.p_code.TrueCodeOfPred));
|
|
}
|
|
if (pe->PredFlags & MegaClausePredFlag) {
|
|
MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
|
|
return Yap_unify(ARG3, MkIntegerTerm(mcl->ClSize/mcl->ClItemSize)) &&
|
|
Yap_unify(ARG4, MkIntegerTerm(mcl->ClSize)) &&
|
|
Yap_unify(ARG5, MkIntegerTerm(isz));
|
|
}
|
|
if (pe->cs.p_code.NOfClauses) {
|
|
do {
|
|
cls++;
|
|
sz += cl->ClSize;
|
|
if (cl->ClCode == pe->cs.p_code.LastClause)
|
|
break;
|
|
cl = cl->ClNext;
|
|
} while (TRUE);
|
|
}
|
|
return Yap_unify(ARG3, MkIntegerTerm(cls)) &&
|
|
Yap_unify(ARG4, MkIntegerTerm(sz)) &&
|
|
Yap_unify(ARG5, MkIntegerTerm(isz));
|
|
}
|
|
|
|
static Int
|
|
p_static_pred_statistics(void)
|
|
{
|
|
Int out;
|
|
PredEntry *pe;
|
|
|
|
pe = get_pred( Deref(ARG1), Deref(ARG2), "predicate_statistics");
|
|
if (pe == NIL)
|
|
return (FALSE);
|
|
LOCK(pe->PELock);
|
|
if (pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) {
|
|
/* should use '$recordedp' in this case */
|
|
UNLOCK(pe->PELock);
|
|
return FALSE;
|
|
}
|
|
out = static_statistics(pe);
|
|
UNLOCK(pe->PELock);
|
|
return out;
|
|
}
|
|
|
|
static Int
|
|
p_predicate_erased_statistics(void)
|
|
{
|
|
UInt sz = 0, cls = 0;
|
|
UInt isz = 0, icls = 0;
|
|
PredEntry *pe;
|
|
LogUpdClause *cl = DBErasedList;
|
|
LogUpdIndex *icl = DBErasedIList;
|
|
Term tpred = ArgOfTerm(2,Deref(ARG1));
|
|
Term tmod = ArgOfTerm(1,Deref(ARG1));
|
|
|
|
if (EndOfPAEntr(pe=get_pred(tpred, tmod, "predicate_erased_statistics")))
|
|
return FALSE;
|
|
while (cl) {
|
|
if (cl->ClPred == pe) {
|
|
cls++;
|
|
sz += cl->ClSize;
|
|
}
|
|
cl = cl->ClNext;
|
|
}
|
|
while (icl) {
|
|
if (pe == icl->ClPred) {
|
|
icls++;
|
|
isz += icl->ClSize;
|
|
}
|
|
icl = icl->SiblingIndex;
|
|
}
|
|
return
|
|
Yap_unify(ARG2,MkIntegerTerm(cls)) &&
|
|
Yap_unify(ARG3,MkIntegerTerm(sz)) &&
|
|
Yap_unify(ARG4,MkIntegerTerm(icls)) &&
|
|
Yap_unify(ARG5,MkIntegerTerm(isz));
|
|
}
|
|
|
|
#ifdef DEBUG
|
|
static Int
|
|
p_predicate_lu_cps(void)
|
|
{
|
|
return Yap_unify(ARG1, MkIntegerTerm(Yap_LiveCps)) &&
|
|
Yap_unify(ARG2, MkIntegerTerm(Yap_FreedCps)) &&
|
|
Yap_unify(ARG3, MkIntegerTerm(Yap_DirtyCps)) &&
|
|
Yap_unify(ARG4, MkIntegerTerm(Yap_NewCps));
|
|
}
|
|
#endif
|
|
|
|
static Int
|
|
p_program_continuation(void)
|
|
{
|
|
PredEntry *pe = EnvPreg((yamop *)((ENV_Parent(ENV))[E_CP]));
|
|
if (pe->ModuleOfPred) {
|
|
if (!Yap_unify(ARG1,pe->ModuleOfPred))
|
|
return FALSE;
|
|
} else {
|
|
if (!Yap_unify(ARG1,TermProlog))
|
|
return FALSE;
|
|
}
|
|
if (pe->ArityOfPE) {
|
|
if (!Yap_unify(ARG2,MkAtomTerm(NameOfFunctor(pe->FunctorOfPred))))
|
|
return FALSE;
|
|
if (!Yap_unify(ARG3,MkIntegerTerm(ArityOfFunctor(pe->FunctorOfPred))))
|
|
return FALSE;
|
|
} else {
|
|
if (!Yap_unify(ARG2,MkAtomTerm((Atom)pe->FunctorOfPred)))
|
|
return FALSE;
|
|
if (!Yap_unify(ARG3,MkIntTerm(0)))
|
|
return FALSE;
|
|
}
|
|
return TRUE;
|
|
}
|
|
|
|
static Term
|
|
BuildActivePred(PredEntry *ap, CELL *vect)
|
|
{
|
|
UInt i;
|
|
|
|
if (!ap->ArityOfPE) {
|
|
return MkVarTerm();
|
|
}
|
|
for (i = 0; i < ap->ArityOfPE; i++) {
|
|
Term t = Deref(vect[i]);
|
|
if (IsVarTerm(t)) {
|
|
CELL *pt = VarOfTerm(t);
|
|
/* one stack */
|
|
if (pt > H) {
|
|
Term nt = MkVarTerm();
|
|
Yap_unify(t, nt);
|
|
}
|
|
}
|
|
}
|
|
return Yap_MkApplTerm(ap->FunctorOfPred, ap->ArityOfPE, vect);
|
|
}
|
|
|
|
static int
|
|
UnifyPredInfo(PredEntry *pe, int start_arg) {
|
|
UInt arity = pe->ArityOfPE;
|
|
Term tmod, tname;
|
|
|
|
if (pe->ModuleOfPred != IDB_MODULE) {
|
|
if (pe->ModuleOfPred == PROLOG_MODULE) {
|
|
tmod = TermProlog;
|
|
} else {
|
|
tmod = pe->ModuleOfPred;
|
|
}
|
|
if (pe->ArityOfPE == 0) {
|
|
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
|
|
} else {
|
|
Functor f = pe->FunctorOfPred;
|
|
tname = MkAtomTerm(NameOfFunctor(f));
|
|
}
|
|
} else {
|
|
tmod = pe->ModuleOfPred;
|
|
if (pe->PredFlags & NumberDBPredFlag) {
|
|
tname = MkIntegerTerm(pe->src.IndxId);
|
|
} else if (pe->PredFlags & AtomDBPredFlag) {
|
|
tname = MkAtomTerm((Atom)pe->FunctorOfPred);
|
|
} else {
|
|
Functor f = pe->FunctorOfPred;
|
|
tname = MkAtomTerm(NameOfFunctor(f));
|
|
}
|
|
}
|
|
|
|
return Yap_unify(XREGS[start_arg], tmod) &&
|
|
Yap_unify(XREGS[start_arg+1],tname) &&
|
|
Yap_unify(XREGS[start_arg+2],MkIntegerTerm(arity));
|
|
}
|
|
|
|
|
|
static Int
|
|
ClauseId(yamop *ipc, PredEntry *pe)
|
|
{
|
|
if (!ipc)
|
|
return 0;
|
|
return find_code_in_clause(pe, ipc, NULL, NULL);
|
|
}
|
|
|
|
static Int
|
|
p_env_info(void)
|
|
{
|
|
PredEntry *pe;
|
|
CELL *env = LCL0-IntegerOfTerm(Deref(ARG1));
|
|
yamop *env_cp;
|
|
Term env_b, taddr;
|
|
|
|
if (!env)
|
|
return FALSE;
|
|
env_b = MkIntegerTerm((Int)(LCL0-(CELL *)env[E_CB]));
|
|
env_cp = (yamop *)env[E_CP];
|
|
|
|
pe = PREVOP(env_cp,Osbpp)->u.Osbpp.p0;
|
|
taddr = MkIntegerTerm((Int)env);
|
|
return Yap_unify(ARG3,MkIntegerTerm((Int)env_cp)) &&
|
|
Yap_unify(ARG2, taddr) &&
|
|
Yap_unify(ARG4, env_b);
|
|
}
|
|
|
|
static Int
|
|
p_cpc_info(void)
|
|
{
|
|
PredEntry *pe;
|
|
yamop *ipc = (yamop *)IntegerOfTerm(Deref(ARG1));
|
|
|
|
pe = PREVOP(ipc,Osbpp)->u.Osbpp.p0;
|
|
return UnifyPredInfo(pe, 2) &&
|
|
Yap_unify(ARG5,MkIntegerTerm(ClauseId(ipc,pe)));
|
|
}
|
|
|
|
static Int
|
|
p_choicepoint_info(void)
|
|
{
|
|
choiceptr cptr = (choiceptr)(LCL0-IntegerOfTerm(Deref(ARG1)));
|
|
PredEntry *pe = NULL;
|
|
int go_on = TRUE;
|
|
yamop *ipc = cptr->cp_ap;
|
|
yamop *ncl = NULL;
|
|
Term t = TermNil, taddr;
|
|
|
|
taddr = MkIntegerTerm((Int)cptr);
|
|
while (go_on) {
|
|
op_numbers opnum = Yap_op_from_opcode(ipc->opc);
|
|
go_on = FALSE;
|
|
switch (opnum) {
|
|
#ifdef TABLING
|
|
case _table_load_answer:
|
|
#ifdef LOW_LEVEL_TRACER
|
|
pe = LOAD_CP(cptr)->cp_pred_entry;
|
|
#else
|
|
pe = UndefCode;
|
|
#endif
|
|
t = MkVarTerm();
|
|
break;
|
|
case _table_try_answer:
|
|
case _table_retry_me:
|
|
case _table_trust_me:
|
|
case _table_retry:
|
|
case _table_trust:
|
|
case _table_completion:
|
|
#ifdef LOW_LEVEL_TRACER
|
|
#ifdef DETERMINISTIC_TABLING
|
|
if (IS_DET_GEN_CP(cptr)) {
|
|
pe = DET_GEN_CP(cptr)->cp_pred_entry;
|
|
t = MkVarTerm();
|
|
} else
|
|
#endif /* DETERMINISTIC_TABLING */
|
|
{
|
|
pe = GEN_CP(cptr)->cp_pred_entry;
|
|
t = BuildActivePred(pe, (CELL *)(GEN_CP(B) + 1));
|
|
}
|
|
#else
|
|
pe = UndefCode;
|
|
t = MkVarTerm();
|
|
#endif
|
|
break;
|
|
case _table_answer_resolution:
|
|
#ifdef LOW_LEVEL_TRACER
|
|
pe = CONS_CP(cptr)->cp_pred_entry;
|
|
#else
|
|
pe = UndefCode;
|
|
#endif
|
|
t = MkVarTerm();
|
|
break;
|
|
case _trie_trust_null:
|
|
case _trie_retry_null:
|
|
case _trie_trust_null_in_new_pair:
|
|
case _trie_retry_null_in_new_pair:
|
|
case _trie_trust_var:
|
|
case _trie_retry_var:
|
|
case _trie_trust_var_in_new_pair:
|
|
case _trie_retry_var_in_new_pair:
|
|
case _trie_trust_val:
|
|
case _trie_retry_val:
|
|
case _trie_trust_val_in_new_pair:
|
|
case _trie_retry_val_in_new_pair:
|
|
case _trie_trust_atom:
|
|
case _trie_retry_atom:
|
|
case _trie_trust_atom_in_new_pair:
|
|
case _trie_retry_atom_in_new_pair:
|
|
case _trie_trust_pair:
|
|
case _trie_retry_pair:
|
|
case _trie_trust_struct:
|
|
case _trie_retry_struct:
|
|
case _trie_trust_struct_in_new_pair:
|
|
case _trie_retry_struct_in_new_pair:
|
|
case _trie_trust_extension:
|
|
case _trie_retry_extension:
|
|
case _trie_trust_float:
|
|
case _trie_retry_float:
|
|
case _trie_trust_long:
|
|
case _trie_retry_long:
|
|
pe = UndefCode;
|
|
t = MkVarTerm();
|
|
break;
|
|
#endif /* TABLING */
|
|
case _try_logical:
|
|
case _retry_logical:
|
|
case _trust_logical:
|
|
case _count_retry_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_retry_logical:
|
|
case _profiled_trust_logical:
|
|
ncl = ipc->u.OtaLl.d->ClCode;
|
|
pe = ipc->u.OtaLl.d->ClPred;
|
|
t = BuildActivePred(pe, cptr->cp_args);
|
|
break;
|
|
case _or_else:
|
|
pe = ipc->u.Osblp.p0;
|
|
ncl = ipc;
|
|
t = Yap_MkNewApplTerm(FunctorOr, 2);
|
|
break;
|
|
|
|
case _or_last:
|
|
#ifdef YAPOR
|
|
pe = ipc->u.Osblp.p0;
|
|
#else
|
|
pe = ipc->u.p.p;
|
|
#endif
|
|
ncl = ipc;
|
|
t = Yap_MkNewApplTerm(FunctorOr, 2);
|
|
break;
|
|
case _retry2:
|
|
case _retry3:
|
|
case _retry4:
|
|
pe = NULL;
|
|
t = TermNil;
|
|
ipc = NEXTOP(ipc,l);
|
|
if (!ncl)
|
|
ncl = ipc->u.Otapl.d;
|
|
go_on = TRUE;
|
|
break;
|
|
case _jump:
|
|
pe = NULL;
|
|
t = TermNil;
|
|
ipc = ipc->u.l.l;
|
|
go_on = TRUE;
|
|
break;
|
|
case _retry_c:
|
|
case _retry_userc:
|
|
ncl = NEXTOP(ipc,OtapFs);
|
|
pe = ipc->u.OtapFs.p;
|
|
t = BuildActivePred(pe, cptr->cp_args);
|
|
break;
|
|
case _retry_profiled:
|
|
case _count_retry:
|
|
pe = NULL;
|
|
t = TermNil;
|
|
ncl = ipc->u.Otapl.d;
|
|
ipc = NEXTOP(ipc,p);
|
|
go_on = TRUE;
|
|
break;
|
|
case _retry_me:
|
|
case _trust_me:
|
|
case _count_retry_me:
|
|
case _count_trust_me:
|
|
case _profiled_retry_me:
|
|
case _profiled_trust_me:
|
|
case _retry_and_mark:
|
|
case _profiled_retry_and_mark:
|
|
case _retry:
|
|
case _trust:
|
|
if (!ncl)
|
|
ncl = ipc->u.Otapl.d;
|
|
pe = ipc->u.Otapl.p;
|
|
t = BuildActivePred(pe, cptr->cp_args);
|
|
break;
|
|
case _Nstop:
|
|
{
|
|
Atom at = AtomLive;
|
|
t = MkAtomTerm(at);
|
|
pe = RepPredProp(PredPropByAtom(at, CurrentModule));
|
|
}
|
|
break;
|
|
case _Ystop:
|
|
default:
|
|
return FALSE;
|
|
}
|
|
}
|
|
return UnifyPredInfo(pe, 3) &&
|
|
Yap_unify(ARG2, taddr) &&
|
|
Yap_unify(ARG6,t) &&
|
|
Yap_unify(ARG7,MkIntegerTerm(ClauseId(ncl,pe)));
|
|
}
|
|
|
|
void
|
|
Yap_InitCdMgr(void)
|
|
{
|
|
Term cm = CurrentModule;
|
|
|
|
Yap_InitCPred("$compile_mode", 2, p_compile_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$set_spy", 2, p_setspy, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$rm_spy", 2, p_rmspy, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
/* gc() may happen during compilation, hence these predicates are
|
|
now unsafe */
|
|
Yap_InitCPred("$compile", 4, p_compile, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$compile_dynamic", 5, p_compile_dynamic, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$purge_clauses", 2, p_purge_clauses, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$in_use", 2, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_metapredicate", 2, p_is_metapredicate, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_expand_goal_or_meta_predicate", 2, p_is_expandgoalormetapredicate, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_log_updatable", 2, p_is_log_updatable, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$owner_file", 3, p_owner_file, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$mk_d", 2, p_mk_d, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$pred_exists", 2, p_pred_exists, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$undefined", 2, p_undefined, SafePredFlag|TestPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$first_clause_in_file", 3, p_first_cl_in_f, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$profile_reset", 2, p_profile_reset, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$is_call_counted", 1, p_is_call_counted, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$call_count_info", 3, p_call_count_info, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$call_count_set", 6, p_call_count_set, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$call_count_reset", 0, p_call_count_reset, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$toggle_static_predicates_in_use", 0, p_toggle_static_predicates_in_use, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$system_predicate", 2, p_system_pred, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$all_system_predicate", 3, p_all_system_pred, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$hide_predicate", 2, p_hide_predicate, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$hidden_predicate", 2, p_hidden_predicate, SafePredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$pred_for_code", 5, p_pred_for_code, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$current_stack", 1, p_current_stack, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$log_update_clause", 4, p_log_update_clause, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$continue_log_update_clause", 5, p_continue_log_update_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$log_update_clause_erase", 4, p_log_update_clause_erase, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$continue_log_update_clause_erase", 5, p_continue_log_update_clause_erase, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$continue_static_clause", 5, p_continue_static_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$static_pred_statistics", 5, p_static_pred_statistics, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$p_nth_clause", 4, p_nth_clause, SyncPredFlag|HiddenPredFlag);
|
|
Yap_InitCPred("$program_continuation", 3, p_program_continuation, SafePredFlag|SyncPredFlag|HiddenPredFlag);
|
|
CurrentModule = HACKS_MODULE;
|
|
Yap_InitCPred("current_choicepoints", 1, p_all_choicepoints, HiddenPredFlag);
|
|
Yap_InitCPred("current_continuations", 1, p_all_envs, HiddenPredFlag);
|
|
Yap_InitCPred("choicepoint", 7, p_choicepoint_info, HiddenPredFlag);
|
|
Yap_InitCPred("continuation", 4, p_env_info, HiddenPredFlag);
|
|
Yap_InitCPred("cp_to_predicate", 5, p_cpc_info, HiddenPredFlag);
|
|
CurrentModule = cm;
|
|
Yap_InitCPred("$predicate_erased_statistics", 5, p_predicate_erased_statistics, SyncPredFlag);
|
|
#ifdef DEBUG
|
|
Yap_InitCPred("$predicate_live_cps", 4, p_predicate_lu_cps, 0L);
|
|
#endif
|
|
}
|
|
|