This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/absmi.c
2015-01-14 04:51:54 -08:00

1769 lines
44 KiB
C
Executable File

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2008-08-13 01:16:26 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.246 2008/08/12 01:27:22 vsc
* MaxOS fixes
* Avoid a thread deadlock
* improvements to SWI predicates.
* make variables_in_term system builtin.
*
* Revision 1.245 2008/08/07 20:51:15 vsc
* more threadin fixes
*
* Revision 1.244 2008/08/06 23:05:49 vsc
* fix debugging info
*
* Revision 1.243 2008/08/06 17:32:18 vsc
* more thread fixes
*
* Revision 1.242 2008/06/17 13:37:48 vsc
* fix c_interface not to crash when people try to recover slots that are
* not there.
* fix try_logical and friends to handle case where predicate has arity 0.
*
* Revision 1.241 2008/06/04 14:47:18 vsc
* make sure we do trim_trail whenever we mess with B!
*
* Revision 1.240 2008/04/04 16:11:40 vsc
* yapor had gotten broken with recent thread changes
*
* Revision 1.239 2008/04/03 13:26:37 vsc
* protect signal handling with locks for threaded version.
* fix close/1 entry in manual (obs from Nicos).
* fix -f option in chr Makefile.
*
* Revision 1.238 2008/04/03 10:50:23 vsc
* term_variables could store local variable in global.
*
* Revision 1.237 2008/03/26 14:37:07 vsc
* more icc fixes
*
* Revision 1.236 2008/03/25 16:45:52 vsc
* make or-parallelism compile again
*
* Revision 1.235 2008/02/12 17:03:50 vsc
* SWI-portability changes
*
* Revision 1.234 2008/01/27 11:01:06 vsc
* make thread code more stable
*
* Revision 1.233 2008/01/23 17:57:44 vsc
* valgrind it!
* enable atom garbage collection.
*
* Revision 1.232 2007/11/28 23:52:14 vsc
* junction tree algorithm
*
* Revision 1.231 2007/11/26 23:43:07 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.230 2007/11/08 15:52:15 vsc
* fix some bugs in new dbterm code.
*
* Revision 1.229 2007/11/07 09:25:27 vsc
* speedup meta-calls
*
* Revision 1.228 2007/11/06 17:02:08 vsc
* compile ground terms away.
*
* Revision 1.227 2007/10/28 11:23:39 vsc
* fix overflow
*
* Revision 1.226 2007/10/28 00:54:09 vsc
* new version of viterbi implementation
* fix all:atvars reporting bad info
* fix bad S info in x86_64
*
* Revision 1.225 2007/10/17 09:18:26 vsc
* growtrail assumed SREG meant ASP?
*
* Revision 1.224 2007/09/24 09:02:31 vsc
* minor bug fixes
*
* Revision 1.223 2007/06/04 12:28:01 vsc
* interface speedups
* bad error message in X is foo>>2.
*
* Revision 1.222 2007/05/01 21:18:19 vsc
* fix bug in saving P at p_eq (obs from Frabrizio Riguzzi)
*
* Revision 1.221 2007/04/10 22:13:20 vsc
* fix max modules limitation
*
* Revision 1.220 2007/03/21 18:32:49 vsc
* fix memory expansion bugs.
*
* Revision 1.219 2007/01/24 09:57:25 vsc
* fix glist_void_varx
*
* Revision 1.218 2006/12/31 01:50:34 vsc
* fix some bugs in call_cleanup: the result of action should not matter,
* and !,fail would not wakeup the delayed goal.
*
* Revision 1.217 2006/12/30 03:25:44 vsc
* call_cleanup/2 and 3
*
* Revision 1.216 2006/12/29 01:57:50 vsc
* allow coroutining plus tabling, this means fixing some trouble with the
* gc and a bug in global variable handling.
*
* Revision 1.215 2006/12/27 01:32:37 vsc
* diverse fixes
*
* Revision 1.214 2006/11/28 00:46:28 vsc
* fix bug in threaded implementation
*
* Revision 1.213 2006/11/27 17:42:02 vsc
* support for UNICODE, and other bug fixes.
*
* Revision 1.212 2006/11/21 16:21:30 vsc
* fix I/O mess
* fix spy/reconsult mess
*
* Revision 1.211 2006/11/15 00:13:36 vsc
* fixes for indexing code.
*
* Revision 1.210 2006/10/25 02:31:07 vsc
* fix emulation of trust_logical
*
* Revision 1.209 2006/10/18 13:47:31 vsc
* index.c implementation of trust_logical was decrementing the wrong
* cp_tr
*
* Revision 1.208 2006/10/11 14:53:57 vsc
* fix memory leak
* fix overflow handling
* VS: ----------------------------------------------------------------------
*
* Revision 1.207 2006/10/10 20:21:42 vsc
* fix new indexing code to actually recover space
* fix predicate info to work for LUs
*
* Revision 1.206 2006/10/10 14:08:15 vsc
* small fixes on threaded implementation.
*
* Revision 1.205 2006/09/28 16:15:54 vsc
* make GMPless version compile.
*
* Revision 1.204 2006/09/20 20:03:51 vsc
* improve indexing on floats
* fix sending large lists to DB
*
* Revision 1.203 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.202 2006/05/24 02:35:39 vsc
* make chr work and other minor fixes.
*
* Revision 1.201 2006/04/27 14:11:57 rslopes
* *** empty log message ***
*
* Revision 1.200 2006/04/12 17:14:58 rslopes
* fix needed by the EAM engine
*
* Revision 1.199 2006/04/12 15:51:23 rslopes
* small fixes
*
* Revision 1.198 2006/03/30 01:11:09 vsc
* fix nasty variable shunting bug in garbage collector :-(:wq
*
* Revision 1.197 2006/03/24 17:13:41 rslopes
* New update to BEAM engine.
* BEAM now uses YAP Indexing (JITI)
*
* Revision 1.196 2006/03/03 23:10:47 vsc
* fix MacOSX interrupt handling
* fix using Yap files as Yap scripts.
*
* Revision 1.195 2006/02/01 13:28:56 vsc
* bignum support fixes
*
* Revision 1.194 2006/01/26 19:13:24 vsc
* avoid compilation issues with lack of gmp (Remko Troncon)
*
* Revision 1.193 2006/01/18 15:34:53 vsc
* avoid sideffects from MkBigInt
*
* Revision 1.192 2006/01/17 14:10:40 vsc
* YENV may be an HW register (breaks some tabling code)
* All YAAM instructions are now brackedted, so Op introduced an { and EndOp introduces an }. This is because Ricardo assumes that.
* Fix attvars when COROUTING is undefined.
*
* Revision 1.191 2006/01/02 02:16:17 vsc
* support new interface between YAP and GMP, so that we don't rely on our own
* allocation routines.
* Several big fixes.
*
* Revision 1.190 2005/12/23 00:20:13 vsc
* updates to gprof
* support for __POWER__
* Try to saveregs before longjmp.
*
* Revision 1.189 2005/12/17 03:25:38 vsc
* major changes to support online event-based profiling
* improve error discovery and restart on scanner.
*
* Revision 1.188 2005/12/05 17:16:10 vsc
* write_depth/3
* overflow handlings and garbage collection
* Several ipdates to CLPBN
* dif/2 could be broken in the presence of attributed variables.
*
* Revision 1.187 2005/11/26 02:57:25 vsc
* improvements to debugger
* overflow fixes
* reading attvars from DB was broken.
*
* Revision 1.186 2005/11/23 03:01:32 vsc
* fix several bugs in save/restore.b
*
* Revision 1.185 2005/11/18 18:48:51 tiagosoares
* support for executing c code when a cut occurs
*
* Revision 1.184 2005/11/15 00:50:49 vsc
* fixes for stack expansion and garbage collection under tabling.
*
* Revision 1.183 2005/11/07 15:35:47 vsc
* fix bugs in garbage collection of tabling.
*
* Revision 1.182 2005/11/05 03:02:33 vsc
* get rid of unnecessary ^ in setof
* Found bug in comparisons
*
* Revision 1.181 2005/11/04 15:39:14 vsc
* absmi should PREG, never P!!
*
* Revision 1.180 2005/10/28 17:38:49 vsc
* sveral updates
*
* Revision 1.179 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.178 2005/10/15 17:05:23 rslopes
* enable profiling on amd64
*
* Revision 1.177 2005/09/09 17:24:37 vsc
* a new and hopefully much better implementation of atts.
*
* Revision 1.176 2005/09/08 22:06:44 rslopes
* BEAM for YAP update...
*
* Revision 1.175 2005/08/12 17:00:00 ricroc
* TABLING FIX: support for incomplete tables
*
* Revision 1.174 2005/08/05 14:55:02 vsc
* first steps to allow mavars with tabling
* fix trailing for tabling with multiple get_cons
*
* Revision 1.173 2005/08/04 15:45:49 ricroc
* TABLING NEW: support to limit the table space size
*
* Revision 1.172 2005/08/02 03:09:48 vsc
* fix debugger to do well nonsource predicates.
*
* Revision 1.171 2005/08/01 15:40:36 ricroc
* TABLING NEW: better support for incomplete tabling
*
* Revision 1.170 2005/07/06 19:33:51 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.169 2005/07/06 15:10:01 vsc
* improvements to compiler: merged instructions and fixes for ->
*
* Revision 1.168 2005/06/04 07:27:33 ricroc
* long int support for tabling
*
* Revision 1.167 2005/06/03 08:26:31 ricroc
* float support for tabling
*
* Revision 1.166 2005/06/01 20:25:22 vsc
* == and \= should not need a choice-point in ->
*
* Revision 1.165 2005/06/01 14:02:45 vsc
* get_rid of try_me?, retry_me? and trust_me? instructions: they are not
* significantly used nowadays.
*
* Revision 1.164 2005/05/26 18:07:32 vsc
* fix warning
*
* Revision 1.163 2005/04/10 04:01:07 vsc
* bug fixes, I hope!
*
* Revision 1.162 2005/04/07 17:48:53 ricroc
* Adding tabling support for mixed strategy evaluation (batched and local scheduling)
* UPDATE: compilation flags -DTABLING_BATCHED_SCHEDULING and -DTABLING_LOCAL_SCHEDULING removed. To support tabling use -DTABLING in the Makefile or --enable-tabling in configure.
* NEW: yap_flag(tabling_mode,MODE) changes the tabling execution mode of all tabled predicates to MODE (batched, local or default).
* NEW: tabling_mode(PRED,MODE) changes the default tabling execution mode of predicate PRED to MODE (batched or local).
*
* Revision 1.161 2005/03/13 06:26:09 vsc
* fix excessive pruning in meta-calls
* fix Term->int breakage in compiler
* improve JPL (at least it does something now for amd64).
*
* Revision 1.160 2005/03/07 17:49:14 vsc
* small fixes
*
* Revision 1.159 2005/03/04 20:29:55 ricroc
* bug fixes for YapTab support
*
* Revision 1.158 2005/03/01 22:25:07 vsc
* fix pruning bug
* make DL_MALLOC less enthusiastic about walking through buckets.
*
* Revision 1.157 2005/02/08 18:04:17 vsc
* library_directory may not be deterministic (usually it isn't).
*
* Revision 1.156 2005/01/13 05:47:25 vsc
* lgamma broke arithmetic optimisation
* integer_y has type y
* pass original source to checker (and maybe even use option in parser)
* use warning mechanism for checker messages.
*
* Revision 1.155 2004/12/28 22:20:34 vsc
* some extra bug fixes for trail overflows: some cannot be recovered that easily,
* some can.
*
* Revision 1.154 2004/12/05 05:01:21 vsc
* try to reduce overheads when running with goal expansion enabled.
* CLPBN fixes
* Handle overflows when allocating big clauses properly.
*
* Revision 1.153 2004/11/19 22:08:35 vsc
* replace SYSTEM_ERROR by out OUT_OF_WHATEVER_ERROR whenever appropriate.
*
* Revision 1.152 2004/11/19 17:14:12 vsc
* a few fixes for 64 bit compiling.
*
* Revision 1.151 2004/11/04 18:22:28 vsc
* don't ever use memory that has been freed (that was done by LU).
* generic fixes for WIN32 libraries
*
* Revision 1.150 2004/10/26 20:15:36 vsc
* More bug fixes for overflow handling
*
* Revision 1.149 2004/10/14 22:14:52 vsc
* don't use a cached version of ARG1 in choice-points
*
* Revision 1.148 2004/09/30 21:37:40 vsc
* fixes for thread support
*
* Revision 1.147 2004/09/30 19:51:53 vsc
* fix overflow from within clause/2
*
* Revision 1.146 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.145 2004/09/17 20:47:35 vsc
* fix some overflows recorded.
*
* Revision 1.144 2004/09/17 19:34:49 vsc
* simplify frozen/2
*
* Revision 1.143 2004/08/16 21:02:04 vsc
* more fixes for !
*
* Revision 1.142 2004/08/11 16:14:51 vsc
* whole lot of fixes:
* - memory leak in indexing
* - memory management in WIN32 now supports holes
* - extend Yap interface, more support for SWI-Interface
* - new predicate mktime in system
* - buffer console I/O in WIN32
*
* Revision 1.141 2004/07/23 21:08:44 vsc
* windows fixes
*
* Revision 1.140 2004/07/22 21:32:20 vsc
* debugger fixes
* initial support for JPL
* bad calls to garbage collector and gc
* debugger fixes
*
* Revision 1.139 2004/07/03 03:29:24 vsc
* make it compile again on non-linux machines
*
* Revision 1.138 2004/06/29 19:04:40 vsc
* fix multithreaded version
* include new version of Ricardo's profiler
* new predicat atomic_concat
* allow multithreaded-debugging
* small fixes
*
* Revision 1.137 2004/06/23 17:24:19 vsc
* New comment-based message style
* Fix thread support (at least don't deadlock with oneself)
* small fixes for coroutining predicates
* force Yap to recover space in arrays of dbrefs
* use private predicates in debugger.
*
* Revision 1.136 2004/06/17 22:07:22 vsc
* bad bug in indexing code.
*
* Revision 1.135 2004/06/09 03:32:02 vsc
* fix bugs
*
* Revision 1.134 2004/06/05 03:36:59 vsc
* coroutining is now a part of attvars.
* some more fixes.
*
* Revision 1.133 2004/05/13 20:54:57 vsc
* debugger fixes
* make sure we always go back to current module, even during initizlization.
*
* Revision 1.132 2004/04/29 03:45:49 vsc
* fix garbage collection in execute_tail
*
* Revision 1.131 2004/04/22 20:07:02 vsc
* more fixes for USE_SYSTEM_MEMORY
*
* Revision 1.130 2004/04/22 03:24:17 vsc
* trust_logical should protect the last clause, otherwise it cannot
* jump there.
*
* Revision 1.129 2004/04/16 19:27:30 vsc
* more bug fixes
*
* Revision 1.128 2004/04/14 19:10:22 vsc
* expand_clauses: keep a list of clauses to expand
* fix new trail scheme for multi-assignment variables
*
* Revision 1.127 2004/03/31 01:03:09 vsc
* support expand group of clauses
*
* Revision 1.126 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.
*
* Revision 1.125 2004/03/10 14:59:54 vsc
* optimise -> for type tests
*
* Revision 1.124 2004/03/08 19:31:01 vsc
* move to 4.5.3
* *
* *
*************************************************************************/
/**
@file absmi.c
@defgroup Efficiency Efficiency Considerations
@ingroup YAPProgramming
We next discuss several issues on trying to make Prolog programs run
fast in YAP. We assume two different programming styles:
+ Execution of <em>deterministic</em> programs often
boils down to a recursive loop of the form:
~~~~~
loop(Env) :-
do_something(Env,NewEnv),
loop(NewEnv).
~~~~~
*/
#define IN_ABSMI_C 1
#define HAS_CACHE_REGS 1
#include "absmi.h"
#include "heapgc.h"
#include "cut_c.h"
#ifdef PUSH_X
#else
/* keep X as a global variable */
Term Yap_XREGS[MaxTemps]; /* 29 */
#endif
#include "arith2.h"
#ifdef COROUTINING
/*
Imagine we are interrupting the execution, say, because we have a spy
point or because we have goals to wake up. This routine saves the current
live temporary registers into a structure pointed to by register ARG1.
The registers are then recovered by a nasty builtin
called
*/
static Term
push_live_regs(yamop *pco)
{
CACHE_REGS
CELL *lab = (CELL *)(pco->y_u.l.l);
CELL max = lab[0];
CELL curr = lab[1];
Term tp = MkIntegerTerm((Int)pco);
Term tcp = MkIntegerTerm((Int)CP);
Term tenv = MkIntegerTerm((Int)(LCL0-ENV));
Term tyenv = MkIntegerTerm((Int)(LCL0-YENV));
CELL *start = HR;
Int tot = 0;
HR++;
*HR++ = tp;
*HR++ = tcp;
*HR++ = tenv;
*HR++ = tyenv;
tot += 4;
{
CELL i;
lab += 2;
for (i=0; i <= max; i++) {
if (i == 8*CellSize) {
curr = lab[0];
lab++;
}
if (curr & 1) {
CELL d1;
tot+=2;
HR[0] = MkIntTerm(i);
d1 = XREGS[i];
deref_head(d1, wake_up_unk);
wake_up_nonvar:
/* just copy it to the heap */
HR[1] = d1;
HR += 2;
continue;
{
CELL *pt0;
deref_body(d1, pt0, wake_up_unk, wake_up_nonvar);
/* bind it, in case it is a local variable */
if (pt0 <= HR) {
/* variable is safe */
HR[1] = (CELL)pt0;
} else {
d1 = Unsigned(HR+1);
RESET_VARIABLE(HR+1);
Bind_Local(pt0, d1);
}
}
HR += 2;
}
curr >>= 1;
}
start[0] = (CELL)Yap_MkFunctor(AtomTrue, tot);
return(AbsAppl(start));
}
}
#endif
#if defined(ANALYST) || defined(DEBUG)
char *Yap_op_names[_std_top + 1] =
{
#define OPCODE(OP,TYPE) #OP
#include "YapOpcodes.h"
#undef OPCODE
};
#endif
static int
check_alarm_fail_int(int CONT USES_REGS)
{
#if defined(_MSC_VER) || defined(__MINGW32__)
/* I need this for Windows and any system where SIGINT
is not proceesed by same thread as absmi */
if (LOCAL_PrologMode & (AbortMode|InterruptMode))
{
CalculateStackGap( PASS_REGS1 );
return CONT;
}
#endif
if (Yap_get_signal( YAP_FAIL_SIGNAL )) {
return false;
}
if (!Yap_has_a_signal()) {
/* no need to look into GC */
CalculateStackGap( PASS_REGS1 );
}
// fail even if there are more signals, they will have to be dealt later.
return -1;
}
static int
stack_overflow( PredEntry *pe, CELL *env, yamop *cp USES_REGS )
{
if ((Int)(Unsigned(YREG) - Unsigned(HR)) < StackGap( PASS_REGS1 ) ||
Yap_get_signal( YAP_STOVF_SIGNAL )) {
S = (CELL *)pe;
if (!Yap_locked_gc(pe->ArityOfPE, env, cp)) {
Yap_NilError(OUT_OF_STACK_ERROR,LOCAL_ErrorMessage);
return 0;
}
return 1;
}
return -1;
}
static int
code_overflow( CELL *yenv USES_REGS )
{
if (Yap_get_signal( YAP_CDOVF_SIGNAL )) {
CELL cut_b = LCL0-(CELL *)(yenv[E_CB]);
/* do a garbage collection first to check if we can recover memory */
if (!Yap_locked_growheap(false, 0, NULL)) {
Yap_NilError(OUT_OF_HEAP_ERROR, "YAP failed to grow heap: %s", LOCAL_ErrorMessage);
return 0;
}
CACHE_A1();
if (yenv == ASP) {
yenv[E_CB] = (CELL)(LCL0-cut_b);
}
return 1;
}
return -1;
}
static int
interrupt_handler( PredEntry *pe USES_REGS )
{
// printf("D %lx %p\n", LOCAL_ActiveSignals, P);
/* tell whether we can creep or not, this is hard because we will
lose the info RSN
*/
BEGD(d0);
d0 = pe->ArityOfPE;
if (d0 == 0) {
HR[1] = MkAtomTerm((Atom) pe->FunctorOfPred);
}
else {
HR[d0 + 2] = AbsAppl(HR);
*HR = (CELL) pe->FunctorOfPred;
HR++;
BEGP(pt1);
pt1 = XREGS + 1;
for (; d0 > 0; --d0) {
BEGD(d1);
BEGP(pt0);
pt0 = pt1;
d1 = *pt0;
deref_head(d1, creep_unk);
creep_nonvar:
/* just copy it to the heap */
pt1++;
*HR++ = d1;
continue;
derefa_body(d1, pt0, creep_unk, creep_nonvar);
if (pt0 <= HR) {
/* variable is safe */
*HR++ = (CELL)pt0;
pt1++;
} else {
/* bind it, in case it is a local variable */
d1 = Unsigned(HR);
RESET_VARIABLE(HR);
pt1++;
HR += 1;
Bind_Local(pt0, d1);
}
ENDP(pt0);
ENDD(d1);
}
ENDP(pt1);
}
ENDD(d0);
HR[0] = Yap_Module_Name(pe);
ARG1 = (Term) AbsPair(HR);
HR += 2;
#ifdef COROUTINING
if (Yap_get_signal( YAP_WAKEUP_SIGNAL )) {
CalculateStackGap( PASS_REGS1 );
ARG2 = Yap_ListOfWokenGoals();
pe = WakeUpCode;
/* no more goals to wake up */
Yap_UpdateTimedVar(LOCAL_WokenGoals,TermNil);
} else
#endif
{
CalculateStackGap( PASS_REGS1 );
pe = CreepCode;
}
P = pe->CodeOfPred;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,pe,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
/* for profiler */
CACHE_A1();
return true;
}
// interrupt handling code that sets up the case when we do not have
// a guaranteed environment.
static int
safe_interrupt_handler( PredEntry *pe USES_REGS )
{
CELL *npt = HR;
// printf("D %lx %p\n", LOCAL_ActiveSignals, P);
/* tell whether we can creep or not, this is hard because we will
lose the info RSN
*/
BEGD(d0);
S = (CELL *)pe;
d0 = pe->ArityOfPE;
if (d0 == 0) {
HR[1] = MkAtomTerm((Atom) pe->FunctorOfPred);
}
else {
HR[d0 + 2] = AbsAppl(HR);
HR += d0+1+2;
*npt++ = (CELL) pe->FunctorOfPred;
BEGP(pt1);
pt1 = XREGS + 1;
for (; d0 > 0; --d0) {
BEGD(d1);
d1 = *pt1;
loop:
if (!IsVarTerm(d1)) {
/* just copy it to the heap */
pt1++;
*npt++ = d1;
} else {
if (VarOfTerm(d1) < H0 || VarOfTerm(d1) > HR) {
d1 = Deref(d1);
if (VarOfTerm(d1) < H0 || VarOfTerm(d1) > HR) {
Term v = MkVarTerm();
YapBind( VarOfTerm(d1),v );
} else {
goto loop;
}
} else {
*npt++ = d1;
}
}
ENDD(d1);
}
ENDP(pt1);
}
ENDD(d0);
npt[0] = Yap_Module_Name(pe);
ARG1 = AbsPair(npt);
HR += 2;
#ifdef COROUTINING
if (Yap_get_signal( YAP_WAKEUP_SIGNAL )) {
CalculateStackGap( PASS_REGS1 );
ARG2 = Yap_ListOfWokenGoals();
pe = WakeUpCode;
/* no more goals to wake up */
Yap_UpdateTimedVar(LOCAL_WokenGoals,TermNil);
} else
#endif
{
CalculateStackGap( PASS_REGS1 );
pe = CreepCode;
}
// allocate and fill out an environment
YENV = ASP;
CACHE_Y_AS_ENV(YREG);
ENV_YREG[E_CP] = (CELL) CP;
ENV_YREG[E_E] = (CELL) ENV;
#ifdef DEPTH_LIMIT
ENV_YREG[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
ENV = ENV_YREG;
ENV_YREG = (CELL *)((CELL)ENV_YREG + ENV_Size(CP));
WRITEBACK_Y_AS_ENV();
ENDCACHE_Y_AS_ENV();
CP = P;
P = pe->CodeOfPred;
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
if (pe->ModuleOfPred) {
if (DEPTH == MkIntTerm(0))
return false;
else DEPTH = RESET_DEPTH();
}
} else if (pe->ModuleOfPred) {
DEPTH -= MkIntConstant(2);
}
#endif /* DEPTH_LIMIT */
return true;
}
static int
interrupt_handlerc( PredEntry *pe USES_REGS )
{
/* do creep in call */
ENV = YENV;
CP = NEXTOP(P, Osbpp);
YENV = (CELL *) (((char *) YENV) + P->y_u.Osbpp.s);
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YENV > (CELL *) top_b || YENV < HR) YENV = (CELL *) top_b;
#else
if (YENV > (CELL *) top_b) YENV = (CELL *) top_b;
#endif /* YAPOR_SBA */
else YENV = YENV + ENV_Size(CP);
}
#else
if (YENV > (CELL *) B)
YENV = (CELL *) B;
else
/* I am not sure about this */
YENV = YENV + ENV_Size(CP);
#endif /* FROZEN_STACKS */
/* setup GB */
YENV[E_CB] = (CELL) B;
return interrupt_handler( pe PASS_REGS );
}
static int
interrupt_handler_either( Term t_cut, PredEntry *pe USES_REGS )
{
int rc;
ARG1 = push_live_regs(NEXTOP(P, Osbpp));
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
// protect registers before we mess about.
// recompute YENV and get ASP
#ifdef YAPOR_SBA
if (YENV > (CELL *) top_b || YENV < HR) YENV = (CELL *) top_b;
#else
if (YENV > (CELL *) top_b) YENV = (CELL *) top_b;
#endif /* YAPOR_SBA */
else YENV = YENV + ENV_Size(CP);
}
#else
if (YENV > (CELL *) B)
YENV = (CELL *) B;
#endif /* FROZEN_STACKS */
P = NEXTOP(P, Osbpp);
// should we cut? If t_cut == INT(0) no
ARG2 = t_cut;
// ASP
SET_ASP(YENV, E_CB*sizeof(CELL));
// do the work.
rc = safe_interrupt_handler( pe PASS_REGS );
return rc;
}
/* to trace interrupt calls */
// #define DEBUG_INTERRUPTS 1
#ifdef DEBUG_INTERRUPTS
static int trace_interrupts = true;
#endif
static int
interrupt_fail( USES_REGS1 )
{
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
check_alarm_fail_int( false PASS_REGS );
/* don't do debugging and stack expansion here: space will
be recovered. automatically by fail, so
better wait.
*/
if (Yap_has_signal( YAP_CREEP_SIGNAL ) ) {
return false;
}
if (Yap_has_signal( YAP_CDOVF_SIGNAL ) ) {
return false;
}
/* make sure we have the correct environment for continuation */
ENV = B->cp_env;
YENV = (CELL *)B;
return interrupt_handler( RepPredProp(Yap_GetPredPropByAtom(AtomFail,0)) PASS_REGS );
}
static int
interrupt_execute( USES_REGS1 )
{
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( true PASS_REGS )) >= 0) {
return v;
}
if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0;
if ((PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2;
}
SET_ASP(YENV, E_CB*sizeof(CELL));
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if ((v = stack_overflow(P->y_u.pp.p, ENV, CP PASS_REGS )) >= 0) {
return v;
}
return interrupt_handler( P->y_u.pp.p PASS_REGS );
}
static int
interrupt_call( USES_REGS1 )
{
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( true PASS_REGS )) >= 0) {
return v;
}
if (PP) UNLOCKPE(1,PP);
PP = P->y_u.Osbpp.p0;
if (Yap_only_has_signal(YAP_CREEP_SIGNAL) &&
(PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) ) {
return 2;
}
SET_ASP(YENV, P->y_u.Osbpp.s);
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if ((v = stack_overflow( P->y_u.Osbpp.p, YENV, NEXTOP(P, Osbpp) PASS_REGS )) >= 0) {
return v;
}
return interrupt_handlerc( P->y_u.Osbpp.p PASS_REGS );
}
static int
interrupt_pexecute( PredEntry *pen USES_REGS )
{
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (PP) UNLOCKPE(1,PP);
PP = NULL;
if (Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2; /* keep on creeping */
}
SET_ASP(YENV, E_CB*sizeof(CELL));
/* setup GB */
YENV[E_CB] = (CELL) B;
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if ((v = stack_overflow( pen, ENV, NEXTOP(P, Osbmp) PASS_REGS )) >= 0) {
return v;
}
CP = NEXTOP(P, Osbmp);
return interrupt_handler( pen PASS_REGS );
}
/* don't forget I cannot creep at deallocate (where to?) */
/* also, this is unusual in that I have already done deallocate,
so I don't need to redo it.
*/
static int
interrupt_deallocate( USES_REGS1 )
{
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( true PASS_REGS )) >= 0) {
return v;
}
/*
don't do a creep here; also, if our instruction is followed by
a execute_c, just wait a bit more */
if ( Yap_only_has_signal( YAP_CREEP_SIGNAL ) ||
/* keep on going if there is something else */
(P->opc != Yap_opcode(_procceed) &&
P->opc != Yap_opcode(_cut_e))) {
return 1;
} else {
CELL cut_b = LCL0-(CELL *)(S[E_CB]);
if (PP) UNLOCKPE(1,PP);
PP = PREVOP(P,p)->y_u.p.p;
ASP = YENV+E_CB;
/* cut_e */
SET_ASP(YENV, E_CB*sizeof(CELL));
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if (Yap_has_a_signal()) {
PredEntry *pe;
if (Yap_op_from_opcode(P->opc) == _cut_e) {
/* followed by a cut */
ARG1 = MkIntegerTerm(LCL0-(CELL *)S[E_CB]);
pe = RepPredProp(Yap_GetPredPropByFunc(FunctorCutBy,1));
} else {
pe = RepPredProp(Yap_GetPredPropByAtom(AtomTrue,0));
}
return interrupt_handler( pe PASS_REGS );
}
if (!Yap_locked_gc(0, ENV, CP)) {
Yap_NilError(OUT_OF_STACK_ERROR,LOCAL_ErrorMessage);
}
S = ASP;
S[E_CB] = (CELL)(LCL0-cut_b);
}
return 1;
}
static int
interrupt_cut( USES_REGS1 )
{
Term t_cut = MkIntegerTerm(LCL0-(CELL *)YENV[E_CB]);
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (!Yap_has_a_signal()
|| Yap_only_has_signals(YAP_CDOVF_SIGNAL , YAP_CREEP_SIGNAL )) {
return 2;
}
/* find something to fool S */
P = NEXTOP(P,s);
return interrupt_handler_either( t_cut, PredRestoreRegs PASS_REGS );
}
static int
interrupt_cut_t( USES_REGS1 )
{
Term t_cut = MkIntegerTerm(LCL0-(CELL *)YENV[E_CB]);
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (!Yap_has_a_signal()
|| Yap_only_has_signals(YAP_CDOVF_SIGNAL , YAP_CREEP_SIGNAL )) {
return 2;
}
/* find something to fool S */
P = NEXTOP(P,s);
return interrupt_handler_either( t_cut, PredRestoreRegs PASS_REGS );
}
static int
interrupt_cut_e( USES_REGS1 )
{
Term t_cut = MkIntegerTerm(LCL0-(CELL *)S[E_CB]);
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (!Yap_only_has_signals(YAP_CDOVF_SIGNAL , YAP_CREEP_SIGNAL )) {
return 2;
}
/* find something to fool S */
P = NEXTOP(P,s);
return interrupt_handler_either( t_cut, PredRestoreRegs PASS_REGS );
}
static int
interrupt_commit_y( USES_REGS1 )
{
int v;
Term t_cut = YENV[P->y_u.yps.y];
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (!Yap_has_a_signal()
|| Yap_only_has_signals(YAP_CDOVF_SIGNAL , YAP_CREEP_SIGNAL )) {
return 2;
}
/* find something to fool S */
P = NEXTOP(P,yps);
return interrupt_handler_either( t_cut, PredRestoreRegs PASS_REGS );
}
static int
interrupt_commit_x( USES_REGS1 )
{
int v;
Term t_cut = XREG(P->y_u.xps.x);
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (Yap_only_has_signals(YAP_CDOVF_SIGNAL , YAP_CREEP_SIGNAL )) {
return 2;
}
if (PP) UNLOCKPE(1,PP);
PP = P->y_u.xps.p0;
/* find something to fool S */
if (P->opc == Yap_opcode(_fcall)) {
/* fill it up */
CACHE_Y_AS_ENV(YREG);
ENV_YREG[E_CP] = (CELL) CP;
ENV_YREG[E_E] = (CELL) ENV;
#ifdef DEPTH_LIMIT
ENV_YREG[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
ENDCACHE_Y_AS_ENV();
}
P = NEXTOP(P,xps);
return interrupt_handler_either( t_cut, PredRestoreRegs PASS_REGS );
}
static int
interrupt_either( USES_REGS1 )
{
int v;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s:%d: (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if ((v = check_alarm_fail_int( 2 PASS_REGS )) >= 0) {
return v;
}
if (Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2;
}
if (PP) UNLOCKPE(1,PP);
PP = P->y_u.Osblp.p0;
/* find something to fool S */
SET_ASP(YENV, P->y_u.Osbpp.s);
if (ASP > (CELL *)PROTECT_FROZEN_B(B))
ASP = (CELL *)PROTECT_FROZEN_B(B);
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if ((v = stack_overflow(RepPredProp(Yap_GetPredPropByFunc(FunctorRestoreRegs1,0)), YENV, NEXTOP(P, Osbpp) PASS_REGS )) >= 0) {
return v;
}
return interrupt_handler_either( MkIntTerm(0), RepPredProp(Yap_GetPredPropByFunc(FunctorRestoreRegs1,0)) PASS_REGS );
}
static int
interrupt_dexecute( USES_REGS1 )
{
int v;
PredEntry *pe;
#ifdef DEBUG_INTERRUPTS
if (trace_interrupts) fprintf(stderr,"[%d] %lu--%lu %s/%d (YENV=%p ENV=%p ASP=%p)\n", worker_id, LOCAL_FirstActiveSignal, LOCAL_LastActiveSignal, \
__FUNCTION__, __LINE__,YENV,ENV,ASP);
#endif
if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0;
pe = P->y_u.pp.p;
if ((pe->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2;
}
/* set S for next instructions */
ASP = YENV+E_CB;
if (ASP > (CELL *)PROTECT_FROZEN_B(B))
ASP = (CELL *)PROTECT_FROZEN_B(B);
if ((v = code_overflow(YENV PASS_REGS)) >= 0) {
return v;
}
if ((v = stack_overflow( P->y_u.pp.p, (CELL *)YENV[E_E], (yamop *)YENV[E_CP] PASS_REGS )) >= 0) {
return v;
}
/* first, deallocate */
CP = (yamop *) YENV[E_CP];
ENV = YENV = (CELL *) YENV[E_E];
#ifdef DEPTH_LIMIT
YENV[E_DEPTH] = DEPTH;
#endif /* DEPTH_LIMIT */
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (YENV > (CELL *) top_b || YENV < HR) YENV = (CELL *) top_b;
#else
if (YENV > (CELL *) top_b) YENV = (CELL *) top_b;
#endif /* YAPOR_SBA */
else YENV = (CELL *) ((CELL)YENV + ENV_Size(CPREG));
}
#else
if (YENV > (CELL *) B) {
YENV = (CELL *) B;
}
else {
YENV = (CELL *) ((CELL) YENV + ENV_Size(CPREG));
}
#endif /* FROZEN_STACKS */
/* setup GB */
YENV[E_CB] = (CELL) B;
/* and now CREEP */
return interrupt_handler( pe PASS_REGS );
}
static void
undef_goal( USES_REGS1 )
{
PredEntry *pe = PredFromDefCode(P);
BEGD(d0);
/* avoid trouble with undefined dynamic procedures */
/* I assume they were not locked beforehand */
#if defined(YAPOR) || defined(THREADS)
if (!PP) {
PELOCK(19,pe);
PP = pe;
}
#endif
if ((pe->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|MultiFileFlag)) ||
CurrentModule == PROLOG_MODULE ||
(UndefCode->OpcodeOfPred == UNDEF_OPCODE)) {
#if defined(YAPOR) || defined(THREADS)
UNLOCKPE(19,PP);
PP = NULL;
#endif
P = FAILCODE;
return;
}
#if defined(YAPOR) || defined(THREADS)
UNLOCKPE(19,PP);
PP = NULL;
#endif
d0 = pe->ArityOfPE;
if (d0 == 0) {
HR[1] = MkAtomTerm((Atom)(pe->FunctorOfPred));
}
else {
HR[d0 + 2] = AbsAppl(HR);
*HR = (CELL) pe->FunctorOfPred;
HR++;
BEGP(pt1);
pt1 = XREGS + 1;
for (; d0 > 0; --d0) {
BEGD(d1);
BEGP(pt0);
pt0 = pt1++;
d1 = *pt0;
deref_head(d1, undef_unk);
undef_nonvar:
/* just copy it to the heap */
*HR++ = d1;
continue;
derefa_body(d1, pt0, undef_unk, undef_nonvar);
if (pt0 <= HR) {
/* variable is safe */
*HR++ = (CELL)pt0;
} else {
/* bind it, in case it is a local variable */
d1 = Unsigned(HR);
RESET_VARIABLE(HR);
HR += 1;
Bind_Local(pt0, d1);
}
ENDP(pt0);
ENDD(d1);
}
ENDP(pt1);
}
ENDD(d0);
HR[0] = Yap_Module_Name(pe);
ARG1 = (Term) AbsPair(HR);
ARG2 = MkIntTerm(getUnknownModule(Yap_GetModuleEntry(HR[0])));
HR += 2;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,UndefCode,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
P = UndefCode->CodeOfPred;
}
static void
spy_goal( USES_REGS1 )
{
PredEntry *pe = PredFromDefCode(P);
#if defined(YAPOR) || defined(THREADS)
if (!PP) {
PELOCK(14,pe);
PP = pe;
}
#endif
BEGD(d0);
if (!(pe->PredFlags & IndexedPredFlag) &&
pe->cs.p_code.NOfClauses > 1) {
/* update ASP before calling IPred */
SET_ASP(YREG, E_CB*sizeof(CELL));
Yap_IPred(pe, 0, CP);
/* IPred can generate errors, it thus must get rid of the lock itself */
if (P == FAILCODE) {
#if defined(YAPOR) || defined(THREADS)
if (PP && !(PP->PredFlags & LogUpdatePredFlag)){
UNLOCKPE(20,pe);
PP = NULL;
}
#endif
return;
}
}
/* first check if we need to increase the counter */
if ((pe->PredFlags & CountPredFlag)) {
LOCK(pe->StatisticsForPred.lock);
pe->StatisticsForPred.NOfEntries++;
UNLOCK(pe->StatisticsForPred.lock);
LOCAL_ReductionsCounter--;
if (LOCAL_ReductionsCounter == 0 && LOCAL_ReductionsCounterOn) {
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(20,pe);
PP = NULL;
}
#endif
Yap_NilError(CALL_COUNTER_UNDERFLOW,"");
return;
}
LOCAL_PredEntriesCounter--;
if (LOCAL_PredEntriesCounter == 0 && LOCAL_PredEntriesCounterOn) {
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(21,pe);
PP = NULL;
}
#endif
Yap_NilError(PRED_ENTRY_COUNTER_UNDERFLOW,"");
return;
}
if ((pe->PredFlags & (CountPredFlag|ProfiledPredFlag|SpiedPredFlag)) ==
CountPredFlag) {
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(22,pe);
PP = NULL;
}
#endif
P = pe->cs.p_code.TrueCodeOfPred;
return;
}
}
/* standard profiler */
if ((pe->PredFlags & ProfiledPredFlag)) {
LOCK(pe->StatisticsForPred.lock);
pe->StatisticsForPred.NOfEntries++;
UNLOCK(pe->StatisticsForPred.lock);
if (!(pe->PredFlags & SpiedPredFlag)) {
P = pe->cs.p_code.TrueCodeOfPred;
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(23,pe);
PP = NULL;
}
#endif
return;
}
}
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCKPE(25,pe);
PP = NULL;
}
#endif
d0 = pe->ArityOfPE;
/* save S for ModuleName */
if (d0 == 0) {
HR[1] = MkAtomTerm((Atom)(pe->FunctorOfPred));
} else {
*HR = (CELL) pe->FunctorOfPred;
HR[d0 + 2] = AbsAppl(HR);
HR++;
BEGP(pt1);
pt1 = XREGS + 1;
for (; d0 > 0; --d0) {
BEGD(d1);
BEGP(pt0);
pt0 = pt1++;
d1 = *pt0;
deref_head(d1, dospy_unk);
dospy_nonvar:
/* just copy it to the heap */
*HR++ = d1;
continue;
derefa_body(d1, pt0, dospy_unk, dospy_nonvar);
if (pt0 <= HR) {
/* variable is safe */
*HR++ = (CELL)pt0;
} else {
/* bind it, in case it is a local variable */
d1 = Unsigned(HR);
RESET_VARIABLE(HR);
HR += 1;
Bind_Local(pt0, d1);
}
ENDP(pt0);
ENDD(d1);
}
ENDP(pt1);
}
ENDD(d0);
HR[0] = Yap_Module_Name(pe);
ARG1 = (Term) AbsPair(HR);
HR += 2;
{
PredEntry *pt0;
#if THREADS
LOCK(GLOBAL_ThreadHandlesLock);
#endif
pt0 = SpyCode;
P_before_spy = P;
P = pt0->CodeOfPred;
/* for profiler */
#if THREADS
UNLOCK(GLOBAL_ThreadHandlesLock);
#endif
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace)
low_level_trace(enter_pred,pt0,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
}
}
Int
Yap_absmi(int inp)
{
CACHE_REGS
#if BP_FREE
/* some function might be using bp for an internal variable, it is the
callee's responsability to save it */
yamop* PCBACKUP = P1REG;
#endif
#ifdef LONG_LIVED_REGISTERS
register CELL d0, d1;
register CELL *pt0, *pt1;
#endif /* LONG_LIVED_REGISTERS */
#ifdef SHADOW_P
register yamop *PREG = P;
#endif /* SHADOW_P */
#ifdef SHADOW_CP
register yamop *CPREG = CP;
#endif /* SHADOW_CP */
#ifdef SHADOW_HB
register CELL *HBREG = HB;
#endif /* SHADOW_HB */
#ifdef SHADOW_Y
register CELL *YREG = Yap_REGS.YENV_;
#endif /* SHADOW_Y */
#ifdef SHADOW_S
register CELL *SREG = Yap_REGS.S_;
#else
#define SREG S
#endif /* SHADOW_S */
/* The indexing register so that we will not destroy ARG1 without
* reason */
#define I_R (XREGS[0])
#if USE_THREADED_CODE
/************************************************************************/
/* Abstract Machine Instruction Address Table */
/* This must be declared inside the function. We use the asm directive */
/* to make it available outside this function */
/************************************************************************/
static void *OpAddress[] =
{
#define OPCODE(OP,TYPE) && OP
#include "YapOpcodes.h"
#undef OPCODE
};
#endif /* USE_THREADED_CODE */
#ifdef SHADOW_REGS
/* work with a local pointer to the registers */
register REGSTORE *regp = &Yap_REGS;
#endif /* SHADOW_REGS */
#if PUSH_REGS
/* useful on a X86 with -fomit-frame-pointer optimisation */
/* The idea is to push REGS onto the X86 stack frame */
/* first allocate local space */
REGSTORE absmi_regs;
REGSTORE *old_regs = Yap_regp;
#endif /* PUSH_REGS */
#ifdef BEAM
CELL OLD_B=B;
extern PredEntry *bpEntry;
if (inp==-9000) {
#if PUSH_REGS
old_regs = &Yap_REGS;
init_absmi_regs(&absmi_regs);
#if THREADS
regcache = Yap_regp
LOCAL_PL_local_data_p->reg_cache = regcache;
#else
Yap_regp = &absmi_regs;
#endif
#endif
CACHE_A1();
PREG=bpEntry->CodeOfPred;
JMPNext(); /* go execute instruction at PREG */
}
#endif
#if USE_THREADED_CODE
/* absmadr */
if (inp > 0) {
Yap_ABSMI_OPCODES = OpAddress;
#if BP_FREE
P1REG = PCBACKUP;
#endif
return(0);
}
#endif /* USE_THREADED_CODE */
#if PUSH_REGS
old_regs = &Yap_REGS;
/* done, let us now initialise this space */
init_absmi_regs(&absmi_regs);
/* the registers are all set up, let's swap */
#ifdef THREADS
pthread_setspecific(Yap_yaamregs_key, (const void *)&absmi_regs);
LOCAL_ThreadHandle.current_yaam_regs = &absmi_regs;
regcache = &absmi_regs;
LOCAL_PL_local_data_p->reg_cache = regcache;
#else
Yap_regp = &absmi_regs;
#endif
#undef Yap_REGS
#define Yap_REGS absmi_regs
#endif /* PUSH_REGS */
#ifdef SHADOW_REGS
/* use regp as a copy of REGS */
regp = &Yap_REGS;
#ifdef REGS
#undef REGS
#endif
#define REGS (*regp)
#endif /* SHADOW_REGS */
setregs();
CACHE_A1();
reset_absmi:
SP = SP0;
#if USE_THREADED_CODE
JMPNext(); /* go execute instruction at P */
#else
/* when we start we are not in write mode */
{
op_numbers opcode = _Ystop;
op_numbers old_op;
#ifdef DEBUG_XX
unsigned long ops_done;
#endif
goto nextop;
nextop_write:
old_op = opcode;
opcode = PREG->y_u.o.opcw;
goto op_switch;
nextop:
old_op = opcode;
opcode = PREG->opc;
op_switch:
#ifdef ANALYST
GLOBAL_opcount[opcode]++;
GLOBAL_2opcount[old_op][opcode]++;
#ifdef DEBUG_XX
ops_done++;
/* if (B->cp_b > 0x103fff90)
fprintf(stderr,"(%ld) doing %s, done %s, B is %p, HB is %p, H is %p\n",
ops_done,Yap_op_names[opcode],Yap_op_names[old_op],B,B->cp_h,HR);*/
#endif
#endif /* ANALYST */
switch (opcode) {
#endif /* USE_THREADED_CODE */
#if !OS_HANDLES_TR_OVERFLOW
notrailleft:
/* if we are within indexing code, the system may have to
* update a S */
{
CELL cut_b;
#ifdef SHADOW_S
S = SREG;
#endif
/* YREG was pointing to where we were going to build the
* next choice-point. The stack shifter will need to know this
* to move the local stack */
SET_ASP(YREG, E_CB*sizeof(CELL));
cut_b = LCL0-(CELL *)(ASP[E_CB]);
saveregs();
if(!Yap_growtrail (0, false)) {
Yap_NilError(OUT_OF_TRAIL_ERROR,"YAP failed to reserve %ld bytes in growtrail",sizeof(CELL) * K16);
setregs();
FAIL();
}
setregs();
#ifdef SHADOW_S
SREG = S;
#endif
if (SREG == ASP) {
SREG[E_CB] = (CELL)(LCL0-cut_b);
}
}
goto reset_absmi;
#endif /* OS_HANDLES_TR_OVERFLOW */
// move instructions to separate file
// so that they are easier to analyse.
#include "absmi_insts.i"
#if !USE_THREADED_CODE
default:
saveregs();
Yap_Error(SYSTEM_ERROR, MkIntegerTerm(opcode), "trying to execute invalid YAAM instruction %d", opcode);
setregs();
FAIL();
}
}
#else
#if PUSH_REGS
restore_absmi_regs(old_regs);
#endif
#if BP_FREE
P1REG = PCBACKUP;
#endif
return (0);
#endif
}
/* dummy function that is needed for profiler */
int Yap_absmiEND(void)
{
return 1;
}