2
** Author(s): Warren, Swift, Xu, Sagonas, Johnson
3
** Contact: xsb-contact@cs.sunysb.edu
5
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1998
6
** Copyright (C) ECRC, Germany, 1990
8
** XSB is free software; you can redistribute it and/or modify it under the
9
** terms of the GNU Library General Public License as published by the Free
10
** Software Foundation; either version 2 of the License, or (at your option)
13
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
14
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
15
** FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for
18
** You should have received a copy of the GNU Library General Public License
19
** along with XSB; if not, write to the Free Software Foundation,
20
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
22
** $Id: emuloop.c,v 1.141 2006/07/21 20:20:46 crued Exp $
26
#include "xsb_config.h"
27
#include "xsb_debug.h"
45
#include "error_xsb.h"
49
#include "memory_xsb.h"
53
#include "varstring_xsb.h"
55
#include "loader_xsb.h"
57
#include "flags_xsb.h"
58
#include "trie_internals.h"
61
#include "macro_xsb.h"
69
#include "orient_xsb.h"
70
#include "io_builtins_xsb.h"
71
#include "unify_xsb.h"
72
#include "emuloop_aux.h"
73
#include "remove_unf.h"
74
#include "thread_xsb.h"
77
#include "debug_xsb.h"
79
#include "struct_manager.h"
83
* Variable ans_var_pos_reg is a pointer to substitution factor of an
84
* answer in the heap. It is used and set in function
85
* variant_answer_search(). The name of this variable is from VarPosReg, a
86
* variable used in variant_call_search() to save the substitution factor
93
//#define MULTI_THREAD_LOGGING
94
#ifdef MULTI_THREAD_LOGGING
95
/* To help debug multithreaded applications:
96
Creates a log-file for each thread, and
97
Logs calls and executes to it.
99
FILE *th_log_file[100] = {NULL};
100
int th_log_cnt[100] = {0};
102
void open_th_log_file(int tid) {
104
sprintf(fname,"temp_th_log_file_%d",tid);
105
th_log_file[tid] = fopen(fname,"w");
109
void log_rec(CTXTdeclc Psc psc, char *ctype) {
110
if (!th_log_file[th->tid]) open_th_log_file(th->tid);
111
fprintf(th_log_file[th->tid],"inst(%d,%s,'%s',%d).\n",++th_log_cnt[th->tid],ctype,get_name(psc),get_arity(psc));
116
/*----------------------------------------------------------------------*/
118
#include "tr_delay.h"
119
#include "tr_code_xsb_i.h"
121
/*----------------------------------------------------------------------*/
122
/* indirect threading-related stuff */
126
#define XSB_Debug_Instr \
127
if (flags[PIL_TRACE]) { \
128
debug_inst(CTXTc lpcreg, ereg); \
134
#define XSB_Debug_Instr
140
#define XSB_Profile_Instr \
141
if (pflags[PROFFLAG]) { \
142
inst_table[(int) *(lpcreg)][sizeof(Cell)+1] \
143
= inst_table[(int) *(lpcreg)][sizeof(Cell)+1] + 1; \
144
if (pflags[PROFFLAG] > 1 && (int) *lpcreg == builtin) \
145
builtin_table[(int) *(lpcreg+3)][1] = \
146
builtin_table[(int) *(lpcreg+3)][1] + 1; \
151
#define XSB_Profile_Instr
155
#define handle_xsb_profile_interrupt \
156
if (asynint_val && (asynint_val & PROFINT_MARK)) { \
157
asynint_val &= ~PROFINT_MARK; \
158
log_prog_ctr(lpcreg); \
161
/* lfcastro: with INSN_BLOCKS, we use a block for each WAM instruction,
162
and define temporary variables locally; otherwise, temp variables are
163
global to the emuloop function.
165
TLS: this experiment does not seem to have worked -- no other
166
occurrences of INSN_BLOCKS in the system.*/
170
#define Def1op register Cell op1;
171
#define Def1fop register float fop2;
172
#define Def2ops register Cell op1, op2;
173
#define Def2fops register Cell op1; register float fop2;
174
#define Def3ops register Cell op1,op2; register CPtr op3;
175
#define DefOps13 register Cell op1; register CPtr op3;
188
#define DefGlobOps register Cell op1,op2; register CPtr op3; float fop2;
192
/* lfcastro: with JUMPTABLE_EMULOOP, we use GCC's first-order labels to
193
create a jumptable for the WAM instructions of emuloop(); otherwise
194
a switch statement is used. */
196
#ifdef JUMPTABLE_EMULOOP
198
static void *instr_addr_table[256];
200
#define XSB_End_Instr() \
203
goto *instr_addr_table[(byte)*lpcreg]; \
207
#define XSB_Next_Instr() \
211
goto *instr_addr_table[(byte)*lpcreg]; \
215
#define XSB_Start_Instr_Chained(Instr,Label) \
218
#define XSB_Start_Instr(Instr,Label) \
223
#else /* no threading */
225
#define XSB_Next_Instr() goto contcase
227
#define XSB_End_Instr() goto contcase; }
229
#define XSB_Start_Instr_Chained(Instr,Label) \
232
#define XSB_Start_Instr(Instr,Label) \
237
/*----------------------------------------------------------------------*/
239
#define get_axx (lpcreg[1])
240
#define get_vxx (ereg-(Cell)lpcreg[1])
241
#define get_rxx (rreg+lpcreg[1])
243
#define get_xax (lpcreg[2])
244
#define get_xvx (ereg-(Cell)lpcreg[2])
245
#define get_xrx (rreg+lpcreg[2])
247
#define get_xxa (lpcreg[3])
248
#define get_xxv (ereg-(Cell)lpcreg[3])
249
#define get_xxr (rreg+lpcreg[3])
251
#define get_xxxl (*(CPtr)(lpcreg+sizeof(Cell)))
252
#define get_xxxs (*(CPtr)(lpcreg+sizeof(Cell)))
253
#define get_xxxc (*(CPtr)(lpcreg+sizeof(Cell)))
254
#define get_xxxn (*(CPtr)(lpcreg+sizeof(Cell)))
255
#define get_xxxg (*(CPtr)(lpcreg+sizeof(Cell)))
256
#define get_xxxi (*(CPtr)(lpcreg+sizeof(Cell)))
257
#define get_xxxf (*(float *)(lpcreg+sizeof(Cell)))
259
#define get_xxxxi (*(CPtr)(lpcreg+sizeof(Cell)*2))
260
#define get_xxxxl (*(CPtr)(lpcreg+sizeof(Cell)*2))
262
#define Op1(Expr) op1 = (Cell)Expr
263
#define Op2(Expr) op2 = (Cell)Expr
264
#define Op2f(Expr) fop2 = (float)Expr
265
#define Op3(Expr) op3 = (CPtr)Expr
267
#define Register(Expr) (cell(Expr))
268
#define Variable(Expr) (cell(Expr))
275
#define ADVANCE_PC(InstrSize) (lpcreg += InstrSize*sizeof(Cell))
277
/* Be sure that flag only has the following two values. */
282
/* TLS Macro does not appear to be used */
284
#define POST_LPCREG_DECL asm ("bp")
286
#define POST_LPCREG_DECL
290
//Below is the implementation of the inline functions for creating and manipulating boxed floats,
291
// declared in cell_xsb.h. They only exist if the FAST_FLOATS tag is undefined. Otherwise, they
292
// are defined as Cell-based macros. See cell_xsb.h for details.
294
inline void bld_boxedfloat(CTXTdeclc CPtr addr, Float value)
296
Float tempFloat = value;
297
new_heap_functor(hreg,box_psc);
298
bld_int(hreg,((ID_BOXED_FLOAT << BOX_ID_OFFSET ) | FLOAT_HIGH_16_BITS(tempFloat) ));
300
bld_int(hreg,FLOAT_MIDDLE_24_BITS(tempFloat)); hreg++;
301
bld_int(hreg,FLOAT_LOW_24_BITS(tempFloat)); hreg++;
302
cell(addr) = makecs(hreg-4);
305
//the below function assumes that the Float type will be exactally twice the size of the
306
// UInteger type. See basictypes.h for the declaration of converter types.
307
inline Float make_float_from_ints(UInteger high, UInteger low)
309
FloatToIntsConv converter;
310
converter.int_vals.high = high;
311
converter.int_vals.low = low;
312
return converter.float_val;
315
inline void bld_boxedfloat(CTXTdeclc CPtr addr, Float value) {
316
bld_float(addr,value);
320
/*----------------------------------------------------------------------*/
321
/* The following macros work for all CPs. Make sure this remains */
323
/*----------------------------------------------------------------------*/
325
#define Fail1 lpcreg = cp_pcreg(breg)
327
#define restore_trail_condition_registers(breg) \
328
if (*breg != (Cell) &check_complete_inst) { \
329
ebreg = cp_ebreg(breg); \
330
hbreg = cp_hreg(breg); \
333
/*----------------------------------------------------------------------*/
335
extern int builtin_call(CTXTdeclc byte), unifunc_call(CTXTdeclc int, CPtr);
336
extern Cell builtin_table[BUILTIN_TBL_SZ][2];
337
extern Pair build_call(CTXTdeclc Psc);
339
extern int is_proper_list(Cell term);
340
extern int is_most_general_term(Cell term);
342
extern void log_prog_ctr(byte *);
343
extern long prof_flag;
346
extern void debug_inst(CTXTdeclc byte *, CPtr);
349
/* TLS: took out unused global.
350
* int debug_assert = 0;
355
int xwammode, level_num;
362
/*----------------------------------------------------------------------*/
364
#include "schedrev_xsb_i.h"
367
#include "wfs_xsb_i.h"
369
#include "complete_local.h"
371
/*----------------------------------------------------------------------*/
373
/* place for a meaningful message when segfault is detected */
374
char *xsb_default_segfault_msg =
375
"\n++Memory violation occurred during evaluation.\n++Please report this problem using the XSB bug tracking system accessible from\n++\t http://sourceforge.net/projects/xsb\n++Please supply the steps necessary to reproduce the bug.\n";
379
jmp_buf xsb_abort_fallback_environment;
382
char *xsb_segfault_message;
384
/*======================================================================*/
385
/* the main emulator loop. */
386
/*======================================================================*/
389
* The WAM instructions are aligned with word (4 bytes on 32-bit machines,
390
* or 8-byte on 64-bit machines), the shortest instructions (like fail)
391
* take one word, and the longest ones take three words (like
392
* switchon3bound). If an instruction takes more than one word, then the
393
* 2nd (or 3rd) word always contains an operand that takes one word. The
394
* one-word operands can be (see file emu/inst_xsb.h):
397
* S - structure symbol
398
* C - constant symbol
401
* I - 2nd & 3rd arguments of switchonbound
402
* F - floating point number
404
* The opcode of all instructions takes the first byte in the first word.
405
* The rest 3 bytes contain operands that needs only one byte. These
406
* one-byte operands can be:
409
* A - one byte number
410
* V - variable offset
411
* R - register number
413
* (In 64-bit machines there are 4 bytes of extra padding space for each
417
int emuloop(CTXTdeclc byte *startaddr)
420
register byte *lpcreg POST_LPCREG_DECL;
422
byte flag = READFLAG; /* read/write mode flag */
423
int restore_type; /* 0 for retry restore; 1 for trust restore */
427
#if (defined(GC) && defined(GC_TEST))
428
/* Used only in the garbage collection test; does not affect emulator o/w */
429
#define GC_INFERENCES 66 /* make sure the garbage collection test is hard */
430
static int infcounter = 0;
433
xsb_segfault_message = xsb_default_segfault_msg;
434
rreg = reg; /* for SUN (TLS ???) */
436
#ifdef JUMPTABLE_EMULOOP
438
#define XSB_INST(INum,Instr,Label,d1,d2,d3,d4) \
439
instr_addr_table[INum] = && Label
440
#include "xsb_inst_list.h"
444
if ((lpcreg = (byte *) setjmp(xsb_abort_fallback_environment))) {
446
* Short circuit untrailing to avoid possible seg faults in
449
trreg = cp_trreg(breg);
450
/* Restore the default signal handling */
451
signal(SIGSEGV, xsb_default_segfault_handler);
453
lpcreg = startaddr; /* first instruction of entire engine */
454
#ifdef JUMPTABLE_EMULOOP
457
contcase: /* the main loop */
459
if (flags[PIL_TRACE]) debug_inst(CTXTc lpcreg, ereg);
463
if (pflags[PROFFLAG]) {
464
inst_table[(int) *(lpcreg)][sizeof(Cell)+1]
465
= inst_table[(int) *(lpcreg)][sizeof(Cell)+1] + 1;
466
if (pflags[PROFFLAG] > 1 && (int) *lpcreg == builtin)
467
builtin_table[(int) *(lpcreg+3)][1] =
468
builtin_table[(int) *(lpcreg+3)][1] + 1;
474
XSB_Start_Instr(getpvar,_getpvar) /* PVR */
476
Op1(Variable(get_xvx));
477
Op2(Register(get_xxr));
478
ADVANCE_PC(size_xxx);
479
/* trailing is needed here because this instruction can also be
480
generated *after* the occurrence of the first call - kostis */
481
bind_copy((CPtr)op1, op2); /* In WAM bld_copy() */
484
XSB_Start_Instr(getpval,_getpval) /* PVR */
486
Op1(Variable(get_xvx));
487
Op2(Register(get_xxr));
488
ADVANCE_PC(size_xxx);
492
XSB_Start_Instr(getstrv,_getstrv) /* PPV-S */
494
Op1(Variable(get_xxv));
496
ADVANCE_PC(size_xxxX);
497
nunify_with_str(op1,op2);
500
XSB_Start_Instr(gettval,_gettval) /* PRR */
502
Op1(Register(get_xrx));
503
Op2(Register(get_xxr));
504
ADVANCE_PC(size_xxx);
508
XSB_Start_Instr(getcon,_getcon) /* PPR-C */
510
Op1(Register(get_xxr));
512
ADVANCE_PC(size_xxxX);
513
nunify_with_con(op1,op2);
516
XSB_Start_Instr(getnil,_getnil) /* PPR */
518
Op1(Register(get_xxr));
519
ADVANCE_PC(size_xxx);
520
nunify_with_nil(op1);
523
XSB_Start_Instr(getstr,_getstr) /* PPR-S */
525
Op1(Register(get_xxr));
527
ADVANCE_PC(size_xxxX);
528
nunify_with_str(op1,op2);
531
XSB_Start_Instr(getlist,_getlist) /* PPR */
533
Op1(Register(get_xxr));
534
ADVANCE_PC(size_xxx);
535
nunify_with_list_sym(op1);
538
XSB_Start_Instr(getattv,_getattv) /* PPR */
540
Op1(Register(get_xxr));
541
ADVANCE_PC(size_xxx);
542
nunify_with_attv(op1);
545
/* TLS: Need trailing here: for a full explanation, see "A Note on
546
Trailing in the SLGWAM on my web page. */
547
XSB_Start_Instr(unipvar,_unipvar) /* PPV */
550
ADVANCE_PC(size_xxx);
551
if (!flag) { /* if (flag == READ) */
552
/* also introduce trailing here - bmd & kostis
553
was: bld_copy((CPtr)op1, *(sreg++)); */
554
bind_copy((CPtr)op1, *(sreg));
557
bind_ref((CPtr)op1, hreg);
562
XSB_Start_Instr(unipval,_unipval) /* PPV */
564
Op1(Variable(get_xxv));
565
ADVANCE_PC(size_xxx);
566
if (flag) { /* if (flag == WRITE) */
575
XSB_Start_Instr(unitvar,_unitvar) /* PPR */
578
ADVANCE_PC(size_xxx);
579
if (!flag) { /* if (flag == READ) */
580
bld_copy((CPtr)op1, *(sreg++));
583
bld_ref((CPtr)op1, hreg);
588
/* "avar" stands for anonymous variable */
589
XSB_Start_Instr(uniavar,_uniavar) /* PPP */
590
ADVANCE_PC(size_xxx);
591
if (!flag) { /* if (flag == READ) */
599
XSB_Start_Instr(unitval,_unitval) /* PPR */
601
Op1(Register(get_xxr));
602
ADVANCE_PC(size_xxx);
603
if (flag) { /* if (flag == WRITE) */
613
XSB_Start_Instr(unicon,_unicon) /* PPP-C */
616
ADVANCE_PC(size_xxxX);
617
if (flag) { /* if (flag == WRITE) */
618
new_heap_string(hreg, (char *)op2);
621
/* op2 already set */
623
nunify_with_con(op1,op2);
627
XSB_Start_Instr(uninil,_uninil) /* PPP */
629
ADVANCE_PC(size_xxx);
630
if (flag) { /* if (flag == WRITE) */
635
nunify_with_nil(op1);
639
XSB_Start_Instr(getnumcon,_getnumcon) /* PPR-B */
641
Op1(Register(get_xxr));
643
ADVANCE_PC(size_xxxX);
644
nunify_with_num(op1,op2);
647
XSB_Start_Instr(getfloat,_getfloat) /* PPR-F */
648
//printf("\nGETFLOAT ENTERED!\n");
650
Op1(Register(get_xxr));
652
ADVANCE_PC(size_xxxX);
653
nunify_with_float_get(op1,fop2);
654
//printf("\nGETFLOAT LEFT!\n");
657
XSB_Start_Instr(putnumcon,_putnumcon) /* PPR-B */
661
op2 = *(pw)(lpcreg+sizeof(Cell));
662
ADVANCE_PC(size_xxxX);
663
bld_oint((CPtr)op1, op2);
666
XSB_Start_Instr(putfloat,_putfloat) /* PPR-F */
667
//printf("\nPUTFLOAT ENTERED!\n");
671
ADVANCE_PC(size_xxxX);
672
// bld_float_tagged((CPtr)op1, fop2);
673
bld_boxedfloat(CTXTc (CPtr)op1, fop2);
674
//printf("\nPUTFLOAT DONE!\n");
677
XSB_Start_Instr(putpvar,_putpvar) /* PVR */
681
ADVANCE_PC(size_xxx);
683
bld_ref((CPtr)op2, (CPtr)op1);
686
/* does not dereference op1 (as opposed to putdval) */
687
XSB_Start_Instr(putpval,_putpval) /* PVR */
691
ADVANCE_PC(size_xxx);
692
bld_copy(op3, *((CPtr)op1));
695
XSB_Start_Instr(puttvar,_puttvar) /* PRR */
699
ADVANCE_PC(size_xxx);
700
bld_ref((CPtr)op1, hreg);
701
bld_ref((CPtr)op2, hreg);
705
/* TLS: Need trailing here: for a full explanation, see "A Note on
706
Trailing in the SLGWAM on my web page. */
707
XSB_Start_Instr(putstrv,_putstrv) /* PPV-S */
711
ADVANCE_PC(size_xxxX);
712
bind_cs((CPtr)op1, (Pair)hreg);
713
new_heap_functor(hreg, (Psc)op2);
716
XSB_Start_Instr(putcon,_putcon) /* PPR-C */
720
ADVANCE_PC(size_xxxX);
721
//printf("PUTCON entered! String is %s\n", (char *) op2);
722
bld_string((CPtr)op1, (char *)op2);
725
XSB_Start_Instr(putnil,_putnil) /* PPR */
728
ADVANCE_PC(size_xxx);
732
/* doc tls -- differs from putstrv since it pulls from a register.
733
Thus the variable is already initialized. */
734
XSB_Start_Instr(putstr,_putstr) /* PPR-S */
738
ADVANCE_PC(size_xxxX);
739
bld_cs((CPtr)op1, (Pair)hreg);
740
new_heap_functor(hreg, (Psc)op2);
743
XSB_Start_Instr(putlist,_putlist) /* PPR */
746
ADVANCE_PC(size_xxx);
747
bld_list((CPtr)op1, hreg);
750
XSB_Start_Instr(putattv,_putattv) /* PPR */
753
ADVANCE_PC(size_xxx);
754
bld_attv((CPtr)op1, hreg);
758
/* TLS: Need trailing here: for a full explanation, see "A Note on
759
Trailing in the SLGWAM on my web page. */
760
XSB_Start_Instr(bldpvar,_bldpvar) /* PPV */
763
ADVANCE_PC(size_xxx);
764
bind_ref((CPtr)op1, hreg); /* trailing is needed: if o/w see ai_tests */
768
XSB_Start_Instr(bldpval,_bldpval) /* PPV */
770
Op1(Variable(get_xxv));
771
ADVANCE_PC(size_xxx);
775
XSB_Start_Instr(bldtvar,_bldtvar) /* PPR */
778
ADVANCE_PC(size_xxx);
779
bld_ref((CPtr)op1, hreg);
783
XSB_Start_Instr(bldavar,_bldavar) /* PPR */
784
ADVANCE_PC(size_xxx);
788
XSB_Start_Instr(bldtval,_bldtval) /* PPR */
790
Op1(Register(get_xxr));
791
ADVANCE_PC(size_xxx);
795
XSB_Start_Instr(bldcon,_bldcon) /* PPP-C */
798
ADVANCE_PC(size_xxxX);
799
new_heap_string(hreg, (char *)op1);
802
XSB_Start_Instr(bldnil,_bldnil) /* PPP */
803
ADVANCE_PC(size_xxx);
807
XSB_Start_Instr(getlist_tvar_tvar,_getlist_tvar_tvar) /* RRR */
809
Op1(Register(get_rxx));
812
ADVANCE_PC(size_xxx);
815
sreg = clref_val(op1);
817
bld_ref((CPtr)op1, *(sreg));
819
bld_ref((CPtr)op1, *(sreg+1));
820
} else if (isref(op1)) {
821
bind_list((CPtr)(op1), hreg);
823
bld_ref((CPtr)op1, hreg);
826
bld_ref((CPtr)op1, hreg);
828
} else if (isattv(op1)) {
829
attv_dbgmsg(">>>> getlist_tvar_tvar: ATTV interrupt needed\n");
830
add_interrupt(CTXTc op1, makelist(hreg));
832
bld_ref((CPtr)op1, hreg);
835
bld_ref((CPtr)op1, hreg);
839
XSB_End_Instr() /* end getlist_tvar_tvar */
841
XSB_Start_Instr(uninumcon,_uninumcon) /* PPP-B */
843
Op2(get_xxxn); /* num in op2 */
844
ADVANCE_PC(size_xxxX);
845
if (flag) { /* if (flag == WRITE) */
846
new_heap_num(hreg, makeint(op2));
850
nunify_with_num(op1,op2);
854
XSB_Start_Instr(unifloat,_unifloat) /* PPPF */
855
//printf("UNIFLOAT ENTERED\n");
857
Op2f(get_xxxf); /* num in fop2 */
858
ADVANCE_PC(size_xxxX);
859
if (flag) { /* if (flag == WRITE) */
860
new_heap_float(hreg, makefloat(fop2));
862
else { /* fop2 set */
864
nunify_with_float(op1,fop2);
866
//printf("UNIFLOAT LEFT\n");
869
XSB_Start_Instr(bldnumcon,_bldnumcon) /* PPP-B */
871
Op1(get_xxxn); /* num to op2 */
872
ADVANCE_PC(size_xxxX);
873
new_heap_num(hreg, (Integer)makeint(op1));
876
XSB_Start_Instr(bldfloat,_bldfloat) /* PPP-F */
877
//printf("BLDFLOAT ENTERED\n");
879
Op2f(get_xxxf); /* num to fop2 */
880
ADVANCE_PC(size_xxxX);
881
new_heap_float(hreg, makefloat(fop2));
882
//printf("BLDFLOAT LEFT\n");
885
XSB_Start_Instr(trymeelse,_trymeelse) /* PPA-L */
891
Psc mypsc = *(CPtr)(cpreg-4);
893
if (get_type(mypsc) == T_PRED) {
894
fprintf(stddbg,"creating_cp(trymeelse(%s/%d), %p).\n",
895
get_name(mypsc), get_arity(mypsc), breg);
899
ADVANCE_PC(size_xxxX);
903
XSB_Start_Instr(dyntrymeelse,_dyntrymeelse) /* PPA-L */
907
ADVANCE_PC(size_xxxX);
910
if (i_have_dyn_mutex) {
911
SYS_MUTEX_UNLOCK(MUTEX_DYNAMIC);
912
i_have_dyn_mutex = 0;
917
XSB_Start_Instr(retrymeelse,_retrymeelse) /* PPA-L */
920
cp_pcreg(breg) = (byte *)get_xxxl;
922
ADVANCE_PC(size_xxxX);
926
/* TLS: added to distinguish dynamic from static choice points when
927
gc-ing retracted clauses. */
929
XSB_Start_Instr(dynretrymeelse,_dynretrymeelse) /* PPA-L */
932
cp_pcreg(breg) = (byte *)get_xxxl;
934
ADVANCE_PC(size_xxxX);
938
/* TLS: according to David. It may be that a call to a
939
* predicate P performs a lot of shallow backtracking esp. to
940
* facts. If so, the interrupt might not be handled until the
941
* engine is not executing P any more. Putting the handler in
942
* trusts means that any interrupt posted during the
943
* backtracking will be caught, and thus gives the profiler a
944
* better chance of accurately reflecting where the time is
947
XSB_Start_Instr(trustmeelsefail,_trustmeelsefail) /* PPA */
951
handle_xsb_profile_interrupt;
952
ADVANCE_PC(size_xxx);
956
XSB_Start_Instr(try,_try) /* PPA-L */
959
op2 = (Cell)((Cell)lpcreg + sizeof(Cell)*2);
962
Psc mypsc = *(CPtr)(cpreg-4);
964
if (get_type(mypsc) == T_PRED) {
965
fprintf(stddbg,"creating_cp(try(%s/%d), %p).\n",
966
get_name(mypsc), get_arity(mypsc), breg);
970
lpcreg = *(pb *)(lpcreg+sizeof(Cell)); /* = *(pointer to byte pointer) */
974
XSB_Start_Instr(retry,_retry) /* PPA-L */
977
cp_pcreg(breg) = lpcreg+sizeof(Cell)*2;
978
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
983
XSB_Start_Instr(trust,_trust) /* PPA-L */
986
handle_xsb_profile_interrupt;
987
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
992
/* Used for tabling: puts a pointer to the subgoal_frame in the
993
local environment for a tabled subgoal */
994
XSB_Start_Instr(getVn,_getVn) /* PPV */
997
ADVANCE_PC(size_xxx);
998
cell((CPtr)op1) = (Cell)tcp_subgoal_ptr(breg);
1001
XSB_Start_Instr(getpbreg,_getpbreg) /* PPV */
1004
ADVANCE_PC(size_xxx);
1005
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
1008
XSB_Start_Instr(gettbreg,_gettbreg) /* PPR */
1011
ADVANCE_PC(size_xxx);
1012
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
1015
XSB_Start_Instr(putpbreg,_putpbreg) /* PPV */
1017
Op1(Variable(get_xxv));
1018
ADVANCE_PC(size_xxx);
1022
XSB_Start_Instr(puttbreg,_puttbreg) /* PPR */
1024
Op1(Register(get_xxr));
1025
ADVANCE_PC(size_xxx);
1029
XSB_Start_Instr(jumptbreg,_jumptbreg) /* PPR-L */ /* ??? */
1032
bld_int((CPtr)op1, ((pb)tcpstack.high - (pb)breg));
1033
lpcreg = *(byte **)(lpcreg+sizeof(Cell));
1035
if (i_have_dyn_mutex) xsb_abort("DYNAMIC MUTEX ERROR\n");
1036
SYS_MUTEX_LOCK(MUTEX_DYNAMIC);
1037
i_have_dyn_mutex = 1;
1041
XSB_Start_Instr(test_heap,_test_heap) /* PPA-N */
1043
Op1(get_xxa); /* op1 = the arity of the procedure */
1045
ADVANCE_PC(size_xxxX);
1047
if ((infcounter++ > GC_INFERENCES) || ((ereg - hreg) < (long)op2))
1050
fprintf(stddbg, ".");
1052
if ((ereg - hreg) < (long)op2)
1055
if (gc_heap(CTXTc op1,FALSE)) { /* garbage collection potentially modifies hreg */
1056
if ((ereg - hreg) < (long)op2) {
1057
if (pflags[STACK_REALLOC]) {
1058
if (glstack_realloc(CTXTc resize_stack(glstack.size,(op2*sizeof(Cell))),op1) != 0) {
1059
xsb_basic_abort(local_global_exception);
1062
xsb_warn("Reallocation is turned OFF !");
1063
xsb_basic_abort(local_global_exception);
1067
/* are there any localy cached quantities that must be reinstalled ? */
1071
XSB_Start_Instr(switchonterm,_switchonterm) /* PPR-L-L */
1073
Op1(Register(get_xxr));
1075
switch (cell_tag(op1)) {
1079
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
1084
ADVANCE_PC(size_xxxXX);
1087
if (isboxedfloat(op1))
1089
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
1092
if (get_arity(get_str_psc(op1)) == 0) {
1093
lpcreg = *(pb *)(lpcreg+sizeof(Cell));
1096
case XSB_LIST: /* include structure case here */
1097
lpcreg = *(pb *)(lpcreg+sizeof(Cell)*2);
1102
#define struct_hash_value(op1) \
1103
(isboxedinteger(op1)?boxedint_val(op1): \
1104
(isboxedfloat(op1)? \
1105
int_val(cell(clref_val(op1)+1)) ^ int_val(cell(clref_val(op1)+2)) ^ int_val(cell(clref_val(op1)+3)): \
1106
(Cell)get_str_psc(op1)))
1108
XSB_Start_Instr(switchonbound,_switchonbound) /* PPR-L-L */
1110
/* op1 is register, op2 is hash table offset, op3 is modulus */
1113
switch (cell_tag(op1)) {
1115
op1 = struct_hash_value(op1);
1117
case XSB_STRING: /* We should change the compiler to avoid this test */
1118
op1 = (Cell)(isnil(op1) ? 0 : string_val(op1));
1121
case XSB_FLOAT: /* cvt to double and use that indexing.... */
1122
op1 = (Cell)int_val(op1);
1125
op1 = (Cell)(list_pscPair);
1130
lpcreg += 3 * sizeof(Cell);
1133
op2 = (Cell)(*(byte **)(lpcreg+sizeof(Cell)));
1134
op3 = *(CPtr *)(lpcreg+sizeof(Cell)*2);
1135
/* doc tls -- op2 + (op1%size)*4 */
1137
*(byte **)((byte *)op2 + ihash((Cell)op1, (Cell)op3) * sizeof(Cell));
1140
XSB_Start_Instr(switchon3bound,_switchon3bound) /* RRR-L-L */
1145
/* op1 is register contents, op2 is hash table offset, op3 is modulus */
1146
indexreg[0] = get_axx;
1147
indexreg[1] = get_xax;
1148
indexreg[2] = get_xxa;
1150
if (*lpcreg == 0) { opa[0] = 0; }
1151
else opa[0] = Register((rreg + (indexreg[0] & 0x7f)));
1152
opa[1] = Register((rreg + (indexreg[1] & 0x7f)));
1153
opa[2] = Register((rreg + (indexreg[2] & 0x7f)));
1154
op2 = (Cell)(*(byte **)(lpcreg+sizeof(Cell)));
1155
op3 = *(CPtr *)(lpcreg+sizeof(Cell)*2);
1156
/* This is not a good way to do this, but until we put retract into C,
1157
or add new builtins, it will have to do. */
1158
for (i = 0; i <= 2; i++) {
1159
if (indexreg[i] != 0) {
1160
if (indexreg[i] > 0x80) {
1162
Cell *stk[MAXTOINDEX];
1163
int argsleft[MAXTOINDEX];
1167
for (k = MAXTOINDEX; k > 0; k--) {
1168
if (depth < 0) break;
1171
if (argsleft[depth] <= 0) depth--;
1174
switch (cell_tag(op1)) {
1178
ADVANCE_PC(size_xxxXX);
1181
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
1182
op1 = (Cell)int_val(op1);
1186
argsleft[depth] = 2;
1187
stk[depth] = clref_val(op1);
1188
op1 = (Cell)(list_pscPair);
1191
if (isboxedinteger(op1)) op1 = (Cell)boxedint_val(op1);
1192
else if (isboxedfloat(op1))
1193
op1 = int_val(cell(clref_val(op1)+1)) ^
1194
int_val(cell(clref_val(op1)+2)) ^
1195
int_val(cell(clref_val(op1)+3));
1198
argsleft[depth] = get_arity(get_str_psc(op1));
1199
stk[depth] = clref_val(op1)+1;
1200
//op1 = (Cell)get_str_psc(op1);
1201
op1 = struct_hash_value(op1);
1205
op1 = (Cell)string_val(op1);
1208
j = (j<<1) + ihash((Cell)op1, (Cell)op3);
1213
switch (cell_tag(op1)) {
1217
ADVANCE_PC(size_xxxXX);
1220
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
1221
op1 = (Cell)int_val(op1);
1224
op1 = (Cell)(list_pscPair);
1227
// op1 = (Cell)get_str_psc(op1);
1228
op1 = struct_hash_value(op1);
1231
op1 = (Cell)string_val(op1);
1234
xsb_error("Illegal operand in switchon3bound");
1237
j = (j<<1) + ihash((Cell)op1, (Cell)op3);
1241
lpcreg = *(byte **)((byte *)op2 + ((j % (Cell)op3) * sizeof(Cell)));
1244
XSB_Start_Instr(switchonthread,_switchonthread) /* PPP-L */
1248
if (th->tid > *((long *)op1+2)) Fail1;
1249
// fprintf(stderr,"switchonthread to %p\n",(pb)(*((long *)op1+3+(th->tid))));
1250
if (!(lpcreg = (pb)(*((long *)op1+3+(th->tid))))) Fail1;
1252
xsb_exit("Not configured for Multithreading");
1256
XSB_Start_Instr(trymeorelse,_trymeorelse) /* PPA-L */
1262
Psc mypsc = *(CPtr)(cpreg-4);
1264
if (get_type(mypsc) == T_PRED) {
1265
fprintf(stddbg,"creating_cp(trymeorelse(%s/%d), %p).\n",
1266
get_name(mypsc), get_arity(mypsc), breg);
1270
ADVANCE_PC(size_xxxX);
1271
cpreg = lpcreg; /* Another use of cpreg for inline try's for disjunctions */
1275
XSB_Start_Instr(retrymeorelse,_retrymeorelse) /* PPA-L */
1278
cp_pcreg(breg) = *(byte **)(lpcreg+sizeof(Cell));
1279
ADVANCE_PC(size_xxxX);
1284
XSB_Start_Instr(trustmeorelsefail,_trustmeorelsefail) /* PPA */
1287
handle_xsb_profile_interrupt;
1288
ADVANCE_PC(size_xxx);
1293
XSB_Start_Instr(dyntrustmeelsefail,_dyntrustmeelsefail) /* PPA-L, second word ignored */
1297
handle_xsb_profile_interrupt;
1298
ADVANCE_PC(size_xxxX);
1303
/*----------------------------------------------------------------------*/
1305
#include "slginsts_xsb_i.h"
1307
#include "tc_insts_xsb_i.h"
1309
/*----------------------------------------------------------------------*/
1311
XSB_Start_Instr(term_comp,_term_comp) /* RRR */
1316
ADVANCE_PC(size_xxx);
1317
bld_int(op3, compare(CTXTc (void *)op1, (void *)op2));
1320
XSB_Start_Instr(movreg,_movreg) /* PRR */
1324
ADVANCE_PC(size_xxx);
1325
bld_copy((CPtr) op2, *((CPtr)op1));
1328
#define ARITHPROC(OP, STROP) \
1329
Op1(Register(get_xrx)); \
1331
ADVANCE_PC(size_xxx); \
1335
if (isinteger(op1)) { \
1336
if (isinteger(op2)) { \
1337
Integer temp = int_val(op2) OP int_val(op1); \
1338
bld_oint(op3, temp); } \
1339
else if (isboxedfloat(op2)) { \
1340
Float temp = boxedfloat_val(op2) OP (Float)int_val(op1); \
1341
bld_boxedfloat(CTXTc op3, temp); } \
1342
else if (isfloat(op2)) { \
1343
Float temp = float_val(op2) OP (Float)int_val(op1); \
1344
bld_boxedfloat(CTXTc op3, temp); } \
1345
else if (isboxedinteger(op2)) { \
1346
Integer temp = boxedint_val(op2) OP int_val(op1); \
1347
bld_oint(op3, temp); } \
1348
else { arithmetic_abort(CTXTc op2, STROP, op1); } \
1350
else if (isfloat(op1)) { \
1351
if (isboxedfloat(op2)) { \
1352
Float temp = boxedfloat_val(op2) OP float_val(op1); \
1353
bld_boxedfloat(CTXTc op3, temp); } \
1354
else if (isfloat(op2)) { \
1355
Float temp = float_val(op2) OP float_val(op1); \
1356
bld_boxedfloat(CTXTc op3, temp); } \
1357
else if (isinteger(op2)) { \
1358
Float temp = (Float)int_val(op2) OP float_val(op1); \
1359
bld_boxedfloat(CTXTc op3, temp); } \
1360
else if (isboxedinteger(op2)) { \
1361
Float temp = (Float)boxedint_val(op2) OP float_val(op1); \
1362
bld_boxedfloat(CTXTc op3, temp); } \
1363
else { arithmetic_abort(CTXTc op2, STROP, op1); } \
1365
else if (isboxedfloat(op1)) { \
1366
if (isboxedfloat(op2)) { \
1367
Float temp = boxedfloat_val(op2) OP boxedfloat_val(op1); \
1368
bld_boxedfloat(CTXTc op3, temp); } \
1369
else if (isfloat(op2)) { \
1370
Float temp = float_val(op2) OP boxedfloat_val(op1); \
1371
bld_boxedfloat(CTXTc op3, temp); } \
1372
else if (isinteger(op2)) { \
1373
Float temp = (Float)int_val(op2) OP boxedfloat_val(op1); \
1374
bld_boxedfloat(CTXTc op3, temp); } \
1375
else if (isboxedinteger(op2)) { \
1376
Float temp = (Float)boxedint_val(op2) OP boxedfloat_val(op1);\
1377
bld_boxedfloat(CTXTc op3, temp); } \
1378
else { arithmetic_abort(CTXTc op2, STROP, op1); } \
1380
else if (isboxedinteger(op1)) { \
1381
if (isinteger(op2)) { \
1382
Integer temp = int_val(op2) OP boxedint_val(op1); \
1383
bld_oint(op3, temp); } \
1384
else if (isboxedinteger(op2)) { \
1385
Integer temp = boxedint_val(op2) OP boxedint_val(op1); \
1386
bld_oint(op3, temp); } \
1387
else if (isboxedfloat(op2)) { \
1388
Float temp = boxedfloat_val(op2) OP (Float)boxedint_val(op1);\
1389
bld_boxedfloat(CTXTc op3, temp); } \
1390
else if (isfloat(op2)) { \
1391
Float temp = float_val(op2) OP (Float)boxedint_val(op1); \
1392
bld_boxedfloat(CTXTc op3, temp); } \
1393
else { arithmetic_abort(CTXTc op2, STROP, op1); } \
1395
else { arithmetic_abort(CTXTc op2, STROP, op1); }
1397
XSB_Start_Instr(addreg,_addreg) /* PRR */
1402
XSB_Start_Instr(subreg,_subreg) /* PRR */
1407
XSB_Start_Instr(mulreg,_mulreg) /* PRR */
1412
/* TLS: cant use ARITHPROC because int/int -> float */
1413
XSB_Start_Instr(divreg,_divreg) /* PRR */
1415
Op1(Register(get_xrx));
1417
ADVANCE_PC(size_xxx);
1421
if (isinteger(op1)) {
1422
if (isinteger(op2)) {
1423
Float temp = (Float)int_val(op2)/(Float)int_val(op1);
1424
bld_boxedfloat(CTXTc op3, temp); }
1425
else if (isofloat(op2)) {
1426
Float temp = ofloat_val(op2)/(Float)int_val(op1);
1427
bld_boxedfloat(CTXTc op3, temp); }
1428
else if (isboxedinteger(op2)) {
1429
Float temp = (Float)boxedint_val(op2)/(Float)int_val(op1);
1430
bld_boxedfloat(CTXTc op3, temp); }
1431
else { arithmetic_abort(CTXTc op2, "/", op1); }
1432
} else if (isofloat(op1)) {
1433
if (isofloat(op2)) {
1434
Float temp = ofloat_val(op2)/ofloat_val(op1);
1435
bld_boxedfloat(CTXTc op3, temp); }
1436
else if (isinteger(op2)) {
1437
Float temp = (Float)int_val(op2)/ofloat_val(op1);
1438
bld_boxedfloat(CTXTc op3, temp); }
1439
else if (isboxedinteger(op2)) {
1440
Float temp = (Float)boxedint_val(op2)/ofloat_val(op1);
1441
bld_boxedfloat(CTXTc op3, temp); }
1442
else { arithmetic_abort(CTXTc op2, "/", op1); }
1443
} else if (isboxedinteger(op1)) {
1444
if (isinteger(op2)) {
1445
Float temp = (Float)int_val(op2) / (Float)boxedint_val(op1);
1446
bld_boxedfloat(CTXTc op3, temp); }
1447
else if (isboxedinteger(op2)) {
1448
Integer temp = (Integer) ((Float)boxedint_val(op2) / (Float)boxedint_val(op1));
1449
bld_boxedfloat(CTXTc op3, temp); }
1450
else if (isofloat(op2)) {
1451
Float temp = (Float)ofloat_val(op2) / (Float)boxedint_val(op1);
1452
bld_boxedfloat(CTXTc op3, temp); }
1453
else { arithmetic_abort(CTXTc op2, "/", op1); }
1454
} else { arithmetic_abort(CTXTc op2, "/", op1); }
1457
XSB_Start_Instr(idivreg,_idivreg) /* PRR */
1459
Op1(Register(get_xrx));
1461
ADVANCE_PC(size_xxx);
1465
if (isinteger(op1)) {
1466
if (int_val(op1) != 0) {
1467
if (isinteger(op2)) {
1468
Integer temp = int_val(op2) / int_val(op1);
1469
bld_oint(op3, temp);
1470
} else if (isboxedinteger(op2)) {
1471
Integer temp = boxedint_val(op2) / int_val(op1);
1472
bld_oint(op3, temp);
1473
} else { arithmetic_abort(CTXTc op2, "//", op1); }
1475
err_handle(CTXTc ZERO_DIVIDE, 2,
1476
"arithmetic expression involving is/2 or eval/2",
1477
2, "non-zero number", op1);
1480
} else if (isboxedinteger(op1)) {
1481
if (isinteger(op2)) {
1482
Integer temp = int_val(op2) / boxedint_val(op1);
1483
bld_oint(op3, temp);
1484
} else if (isboxedinteger(op2)) {
1485
Integer temp = boxedint_val(op2) / boxedint_val(op1);
1486
bld_oint(op3, temp);
1489
else { arithmetic_abort(CTXTc op2, "//", op1); }
1492
XSB_Start_Instr(int_test_z,_int_test_z) /* PPR-B-L */
1494
Op1(Register(get_xxr));
1497
ADVANCE_PC(size_xxxXX);
1499
if (isnumber(op1)) {
1500
if (int_val(op1) == (Integer)op2)
1501
lpcreg = (byte *)op3;
1503
else if (isboxedinteger(op1)) {
1504
if (oint_val(op1) == (Integer)op2)
1505
lpcreg = (byte *)op3;
1507
else if (isboxedfloat(op1)) {
1508
if (ofloat_val(op1) == (double)op2)
1509
lpcreg = (byte *) op3;
1512
arithmetic_comp_abort(CTXTc op1, "=\\=", op2);
1516
XSB_Start_Instr(int_test_nz,_int_test_nz) /* PPR-B-L */
1518
Op1(Register(get_xxr));
1521
ADVANCE_PC(size_xxxXX);
1523
if (isnumber(op1)) {
1524
if (int_val(op1) != (Integer)op2)
1525
lpcreg = (byte *) op3;
1527
else if (isboxedinteger(op1)) {
1528
if (oint_val(op1) != (Integer)op2)
1529
lpcreg = (byte *)op3;
1531
else if (isboxedfloat(op1)) {
1532
if (ofloat_val(op1) != (double)op2)
1533
lpcreg = (byte *) op3;
1536
arithmetic_comp_abort(CTXTc op1, "=:=", op2);
1540
/* Used for the @=/2 operator */
1541
XSB_Start_Instr(fun_test_ne,_fun_test_ne) /* PRR-L */
1543
Op1(Register(get_xrx));
1544
Op2(Register(get_xxr));
1547
if (isconstr(op1)) {
1548
if (!isconstr(op2) || get_str_psc(op1) != get_str_psc(op2)) {
1550
lpcreg = (byte *) op3;
1552
ADVANCE_PC(size_xxxX);
1554
} else if (islist(op1)) {
1557
lpcreg = (byte *) op3;
1559
else ADVANCE_PC(size_xxxX);
1563
lpcreg = (byte *) op3;
1565
else ADVANCE_PC(size_xxxX);
1569
/* TLS: so much work for such a little function! */
1570
XSB_Start_Instr(minreg,_minreg) /* PRR */
1572
Op1(Register(get_xrx));
1574
ADVANCE_PC(size_xxx);
1578
if (isinteger(op1)) {
1579
if (isinteger(op2)) {
1580
if (int_val(op2) < int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1582
if (isboxedinteger(op2)) {
1583
if (boxedint_val(op2) < int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1585
if (isofloat(op2)) {
1586
if (ofloat_val(op2) < int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1589
else if (isboxedinteger(op1)) {
1590
if (isinteger(op2)) {
1591
if (int_val(op2) < boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1593
if (isboxedinteger(op2)) {
1594
if (boxedint_val(op2) < boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1596
if (isofloat(op2)) {
1597
if (ofloat_val(op2) < boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1600
else if (isofloat(op1)) {
1601
if (isinteger(op2)) {
1602
if (int_val(op2) < ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1604
if (isboxedinteger(op2)) {
1605
if (boxedint_val(op2) < ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1607
if (isofloat(op2)) {
1608
if (ofloat_val(op2) < ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1611
else { arithmetic_abort(CTXTc op2, "min", op1); }
1614
/* TLS: so much work for such a little function! */
1615
XSB_Start_Instr(maxreg,_maxreg) /* PRR */
1617
Op1(Register(get_xrx));
1619
ADVANCE_PC(size_xxx);
1623
if (isinteger(op1)) {
1624
if (isinteger(op2)) {
1625
if (int_val(op2) > int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1627
if (isboxedinteger(op2)) {
1628
if (boxedint_val(op2) > int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1630
if (isofloat(op2)) {
1631
if (ofloat_val(op2) > int_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1634
else if (isboxedinteger(op1)) {
1635
if (isinteger(op2)) {
1636
if (int_val(op2) > boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1638
if (isboxedinteger(op2)) {
1639
if (boxedint_val(op2) > boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1641
if (isofloat(op2)) {
1642
if (ofloat_val(op2) > boxedint_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1645
else if (isofloat(op1)) {
1646
if (isinteger(op2)) {
1647
if (int_val(op2) > ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1649
if (isboxedinteger(op2)) {
1650
if (boxedint_val(op2) > ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1652
if (isofloat(op2)) {
1653
if (ofloat_val(op2) > ofloat_val(op1)) bld_copy(op3,op2); else bld_copy(op3,op1);
1656
else { arithmetic_abort(CTXTc op2, "min", op1); }
1660
/* dereferences op1 (as opposed to putpval) */
1661
XSB_Start_Instr(putdval,_putdval) /* PVR */
1663
Op1(Variable(get_xvx));
1665
ADVANCE_PC(size_xxx);
1667
bld_copy((CPtr)op2, op1);
1670
XSB_Start_Instr(putuval,_putuval) /* PVR */
1672
Op1(Variable(get_xvx));
1674
ADVANCE_PC(size_xxx);
1676
if (isnonvar(op1) || ((CPtr)(op1) < hreg) || ((CPtr)(op1) >= ereg)) {
1677
bld_copy((CPtr)op2, op1);
1679
bld_ref((CPtr)op2, hreg);
1680
bind_ref((CPtr)(op1), hreg);
1681
new_heap_free(hreg);
1686
* Instruction `check_interrupt' is used before `new_answer_dealloc' to
1687
* handle the pending attv interrupts. It is similar to `call' but the
1688
* second argument (S) is not used currently.
1690
XSB_Start_Instr(check_interrupt,_check_interrupt) /* PPA-S */
1694
ADVANCE_PC(size_xxxX);
1695
if (int_val(cell(interrupt_reg)) > 0) {
1697
bld_cs(reg + 2, hreg); /* see subp.c: build_call() */
1698
new_heap_functor(hreg, true_psc);
1699
bld_copy(reg + 1, build_interrupt_chain(CTXT));
1700
lpcreg = get_ep((Psc) pflags[MYSIG_ATTV + INT_HANDLERS_FLAGS_START]);
1704
XSB_Start_Instr(call,_call) /* PPA-S */
1708
Op1(get_xxxs); /* the first arg is used later by alloc */
1709
ADVANCE_PC(size_xxxX);
1715
#ifdef MULTI_THREAD_LOGGING
1716
log_rec(CTXTc psc, "call");
1721
/* If using the multi-threaded engine, call the function with the
1722
single argument, CTXT; otherwise call a parameterless
1724
XSB_Start_Instr(call_forn,_call_forn) {
1727
ADVANCE_PC(size_xxxX);
1730
if (fp(CTXT)) /* call foreign function */
1734
if (((PFI)op1)()) /* call foreign function */
1741
XSB_Start_Instr(load_pred,_load_pred) /* PPP-S */
1746
SYS_MUTEX_LOCK(MUTEX_LOAD_UNDEF);
1747
ADVANCE_PC(size_xxxX);
1749
/* check env or type to give (better) error msgs? */
1750
switch (get_type(psc)) {
1754
#ifndef MULTI_THREAD
1755
xsb_abort("[EMULOOP] Trying to load an already loaded pred");
1757
/* predicate was loaded by another thread */
1758
/* fprintf(stderr,"Predicate loaded by other thread\n");
1761
SYS_MUTEX_UNLOCK(MUTEX_LOAD_UNDEF);
1762
lpcreg = get_ep(psc); /* new ep of predicate */
1766
/* xsb_dbgmsg("loading module %s for %s/%d\n",
1767
get_name(get_data(psc)),get_name(psc),get_arity(psc)); */
1768
bld_cs(reg+1, build_call(CTXTc psc)); /* put call-term in r1 */
1769
/* get psc of undef handler */
1770
psc = (Psc)pflags[MYSIG_UNDEF+INT_HANDLERS_FLAGS_START];
1771
bld_int(reg+2, MYSIG_UNDEF); /* undef-pred code */
1772
lpcreg = get_ep(psc); /* ep of undef handler */
1777
XSB_Start_Instr(allocate_gc,_allocate_gc) /* PAA */
1780
Op3((CPtr) (Cell)get_xxa);
1781
ADVANCE_PC(size_xxx);
1782
if (efreg_on_top(ereg))
1783
op1 = (Cell)(efreg-1);
1785
if (ereg_on_top(ereg)) op1 = (Cell)(ereg - *(cpreg-2*sizeof(Cell)+3));
1786
else op1 = (Cell)(ebreg-1);
1788
*(CPtr *)((CPtr) op1) = ereg;
1789
*((byte **) (CPtr)op1-1) = cpreg;
1791
{/* initialize all permanent variables not in the first chunk to unbound */
1792
int i = ((Cell)op3) - op2;
1793
CPtr p = ((CPtr)op1) - op2;
1801
/* This is obsolete and is only kept for backwards compatibility for < 2.0 */
1802
XSB_Start_Instr(allocate,_allocate) /* PPP */
1804
ADVANCE_PC(size_xxx);
1805
if (efreg_on_top(ereg))
1806
op1 = (Cell)(efreg-1);
1808
if (ereg_on_top(ereg)) op1 = (Cell)(ereg - *(cpreg-2*sizeof(Cell)+3));
1809
else op1 = (Cell)(ebreg-1);
1811
*(CPtr *)((CPtr) op1) = ereg;
1812
*((byte **) (CPtr)op1-1) = cpreg;
1814
{ /* for old object files initialize pessimisticly but safely */
1816
CPtr p = ((CPtr)op1)-2;
1824
XSB_Start_Instr(deallocate,_deallocate) /* PPP */
1825
ADVANCE_PC(size_xxx);
1826
cpreg = *((byte **)ereg-1);
1827
ereg = *(CPtr *)ereg;
1830
XSB_Start_Instr(proceed,_proceed) /* PPP */
1834
/* This is the WAM-execute. Name was changed because of conflict
1835
with some system files for pthreads. */
1836
XSB_Start_Instr(xsb_execute,_xsb_execute) /* PPP-S */
1841
ADVANCE_PC(size_xxxX);
1843
#ifdef MULTI_THREAD_LOGGING
1844
log_rec(CTXTc psc, "exec");
1852
XSB_Start_Instr(jump,_jump) /* PPP-L */
1853
lpcreg = (byte *)get_xxxl;
1856
XSB_Start_Instr(jumpz,_jumpz) /* PPR-L */
1858
Op1(Register(get_xxr));
1859
if (isinteger(op1)) {
1860
if (int_val(op1) == 0) {
1861
lpcreg = (byte *)get_xxxl;
1862
} else {ADVANCE_PC(size_xxxX);}
1863
} else if (isofloat(op1)) {
1864
if (ofloat_val(op1) == 0.0) {
1865
lpcreg = (byte *)get_xxxl;
1866
} else {ADVANCE_PC(size_xxxX);}
1867
} else if (isboxedinteger(op1)){
1868
if (boxedint_val(op1) == 0){
1869
lpcreg = (byte *)get_xxxl;
1870
} else {ADVANCE_PC(size_xxxX);}
1874
XSB_Start_Instr(jumpnz,_jumpnz) /* PPR-L */
1876
Op1(Register(get_xxr));
1877
if (isinteger(op1)) {
1878
if (int_val(op1) != 0) {
1879
lpcreg = (byte *)get_xxxl;
1880
} else {ADVANCE_PC(size_xxxX);}
1881
} else if (isofloat(op1)) {
1882
if (ofloat_val(op1) != 0.0) {
1883
lpcreg = (byte *)get_xxxl;
1884
} else {ADVANCE_PC(size_xxxX);}
1885
} else if (isboxedinteger(op1)){
1886
if (boxedint_val(op1) != 0){
1887
lpcreg = (byte *)get_xxxl;
1888
} else {ADVANCE_PC(size_xxxX);}
1892
XSB_Start_Instr(jumplt,_jumplt) /* PPR-L */
1894
Op1(Register(get_xxr));
1895
if (isinteger(op1)) {
1896
if (int_val(op1) < 0) lpcreg = (byte *)get_xxxl;
1897
else {ADVANCE_PC(size_xxxX);}
1898
} else if (isofloat(op1)) {
1899
if (ofloat_val(op1) < 0.0) lpcreg = (byte *)get_xxxl;
1900
else {ADVANCE_PC(size_xxxX);}
1901
} else if (isboxedinteger(op1)) {
1902
if (boxedint_val(op1) < 0) lpcreg = (byte *)get_xxxl;
1903
else {ADVANCE_PC(size_xxxX);}
1907
XSB_Start_Instr(jumple,_jumple) /* PPR-L */
1909
Op1(Register(get_xxr));
1910
if (isinteger(op1)) {
1911
if (int_val(op1) <= 0) lpcreg = (byte *)get_xxxl;
1912
else {ADVANCE_PC(size_xxxX);}
1913
} else if (isofloat(op1)) {
1914
if (ofloat_val(op1) <= 0.0) lpcreg = (byte *)get_xxxl;
1915
else {ADVANCE_PC(size_xxxX);}
1916
} else if (isboxedinteger(op1)) {
1917
if (boxedint_val(op1) <= 0) lpcreg = (byte *)get_xxxl;
1918
else {ADVANCE_PC(size_xxxX);}
1922
XSB_Start_Instr(jumpgt,_jumpgt) /* PPR-L */
1924
Op1(Register(get_xxr));
1925
if (isinteger(op1)) {
1926
if (int_val(op1) > 0) lpcreg = (byte *)get_xxxl;
1927
else {ADVANCE_PC(size_xxxX);}
1928
} else if (isofloat(op1)) {
1929
if (ofloat_val(op1) > 0.0) lpcreg = (byte *)get_xxxl;
1930
else {ADVANCE_PC(size_xxxX);}
1931
} else if (isboxedinteger(op1)) {
1932
if (boxedint_val(op1) > 0) lpcreg = (byte *)get_xxxl;
1933
else {ADVANCE_PC(size_xxxX);}
1937
XSB_Start_Instr(jumpge,_jumpge) /* PPR-L */
1939
Op1(Register(get_xxr));
1940
if (isinteger(op1)) {
1941
if (int_val(op1) >= 0) lpcreg = (byte *)get_xxxl;
1942
else {ADVANCE_PC(size_xxxX);}
1943
} else if (isofloat(op1)) {
1944
if (ofloat_val(op1) >= 0.0) lpcreg = (byte *)get_xxxl;
1945
else {ADVANCE_PC(size_xxxX);}
1946
} else if (isboxedinteger(op1)) {
1947
if (boxedint_val(op1) >= 0) lpcreg = (byte *)get_xxxl;
1948
else {ADVANCE_PC(size_xxxX);}
1952
XSB_Start_Instr(fail,_fail) /* PPP */
1956
XSB_Start_Instr(dynfail,_dynfail) /* PPP */
1958
if (i_have_dyn_mutex) {
1959
SYS_MUTEX_UNLOCK(MUTEX_DYNAMIC);
1960
i_have_dyn_mutex = 0;
1966
XSB_Start_Instr(noop,_noop) /* PPA */
1969
ADVANCE_PC(size_xxx);
1974
XSB_Start_Instr(dynnoop,_dynnoop) /* PPA */
1977
ADVANCE_PC(size_xxx);
1981
if (i_have_dyn_mutex) {
1982
SYS_MUTEX_UNLOCK(MUTEX_DYNAMIC);
1983
i_have_dyn_mutex = 0;
1988
XSB_Start_Instr(halt,_halt) /* PPP */
1989
ADVANCE_PC(size_xxx);
1991
inst_begin_gl = lpcreg; /* hack for the moment to make this a ``creturn'' */
1992
return(0); /* not "goto contcase"! */
1995
XSB_Start_Instr(builtin,_builtin)
1998
ADVANCE_PC(size_xxx);
2000
if (builtin_call(CTXTc (byte)(op1))) {lpcreg=pcreg;}
2004
#define jump_cond_fail(Condition) \
2005
if (Condition) {ADVANCE_PC(size_xxxX);} else lpcreg = (byte *)get_xxxl
2007
XSB_Start_Instr(jumpcof,_jumpcof)
2014
jump_cond_fail(isatom(op2));
2017
jump_cond_fail(isinteger(op2) || isboxedinteger(op2));
2020
jump_cond_fail(isofloat(op2));
2023
jump_cond_fail(isnumber(op2) || isboxedinteger(op2) || isboxedfloat(op2));
2026
jump_cond_fail(isatomic(op2) || isboxedinteger(op2) || isboxedfloat(op2));
2029
jump_cond_fail(((isconstr(op2) && get_arity(get_str_psc(op2))) ||
2030
(islist(op2))) && !isboxedfloat(op2) && !isboxedinteger(op2));
2033
jump_cond_fail((isconstr(op2) && !isboxed(op2)) || isstring(op2) || islist(op2));
2036
jump_cond_fail(is_proper_list(op2));
2038
case IS_MOST_GENERAL_TERM_TEST:
2039
jump_cond_fail(is_most_general_term(op2));
2042
jump_cond_fail(isattv(op2));
2045
jump_cond_fail(isref(op2) || isattv(op2));
2048
jump_cond_fail(isnonvar(op2) && !isattv(op2));
2051
xsb_error("Undefined jumpcof condition");
2056
XSB_Start_Instr(unifunc,_unifunc) /* PAR */
2060
ADVANCE_PC(size_xxx);
2061
if (unifunc_call(CTXTc (int)(op1), (CPtr)op2) == 0) {
2062
xsb_error("Error in unary function call");
2067
/* Calls internal code -- does not go through psc record and omits
2068
interrupt checks. Not sure if profile_interrupt should be here...*/
2069
XSB_Start_Instr(calld,_calld) /* PPA-L */
2070
ADVANCE_PC(size_xxx); /* this is ok */
2071
cpreg = lpcreg+sizeof(Cell);
2072
/*check_glstack_overflow(MAX_ARITY, lpcreg,OVERFLOW_MARGIN); try eliminating?? */
2073
handle_xsb_profile_interrupt;
2074
lpcreg = *(pb *)lpcreg;
2077
XSB_Start_Instr(logshiftr,_logshiftr) /* PRR */
2079
Op1(Register(get_xrx));
2081
ADVANCE_PC(size_xxx);
2085
if (isinteger(op1)) {
2086
if (isinteger(op2)) {
2087
Integer temp = int_val(op2) >> int_val(op1);
2088
bld_oint(op3, temp);
2090
else if (isboxedinteger(op2)) {
2091
Integer temp = boxedint_val(op2) >> int_val(op1);
2092
bld_oint(op3, temp);
2094
else {arithmetic_abort(CTXTc op2, "'>>'", op1);}
2096
else if (isboxedinteger(op1)) {
2097
if (isinteger(op2)) {
2098
Integer temp = int_val(op2) >> boxedint_val(op1);
2099
bld_oint(op3, temp);
2101
else if (isboxedinteger(op2)) {
2102
Integer temp = boxedint_val(op2) >> boxedint_val(op1);
2103
bld_oint(op3, temp);
2105
else {arithmetic_abort(CTXTc op2, "'>>'", op1);}
2107
else {arithmetic_abort(CTXTc op2, "'>>'", op1);}
2110
XSB_Start_Instr(logshiftl,_logshiftl) /* PRR */
2112
Op1(Register(get_xrx));
2114
ADVANCE_PC(size_xxx);
2118
if (isinteger(op1)) {
2119
if (isinteger(op2)) {
2120
Integer temp = int_val(op2) << int_val(op1);
2121
bld_oint(op3, temp);
2123
else if (isboxedinteger(op2)) {
2124
Integer temp = boxedint_val(op2) << int_val(op1);
2125
bld_oint(op3, temp);
2127
else {arithmetic_abort(CTXTc op2, "'<<'", op1);}
2129
else if (isboxedinteger(op1)) {
2130
if (isinteger(op2)) {
2131
Integer temp = int_val(op2) << boxedint_val(op1);
2132
bld_oint(op3, temp);
2134
else if (isboxedinteger(op2)) {
2135
Integer temp = boxedint_val(op2) << boxedint_val(op1);
2136
bld_oint(op3, temp);
2138
else {arithmetic_abort(CTXTc op2, "'<<'", op1);}
2140
else {arithmetic_abort(CTXTc op2, "'<<'", op1);}
2143
XSB_Start_Instr(or,_or) /* PRR */
2145
Op1(Register(get_xrx));
2147
ADVANCE_PC(size_xxx);
2151
if (isinteger(op1)) {
2152
if (isinteger(op2)) {
2153
Integer temp = (int_val(op2)) | (int_val(op1));
2154
bld_oint(op3, temp);
2156
else if (isboxedinteger(op2)) {
2157
Integer temp = (boxedint_val(op2)) | (int_val(op1));
2158
bld_oint(op3, temp);
2160
else {arithmetic_abort(CTXTc op2, "'\\/'", op1);}
2162
else if (isboxedinteger(op1)) {
2163
if (isinteger(op2)) {
2164
Integer temp = (int_val(op2)) | (boxedint_val(op1));
2165
bld_oint(op3, temp);
2167
else if (isboxedinteger(op2)) {
2168
Integer temp = (boxedint_val(op2)) | (boxedint_val(op1));
2169
bld_oint(op3, temp);
2171
else {arithmetic_abort(CTXTc op2, "'\\/'", op1);}
2173
else {arithmetic_abort(CTXTc op2, "'\\/'", op1);}
2174
/** if (!isinteger(op1) || !isinteger(op2)) {
2175
arithmetic_abort(CTXTc op2, "'\\/'", op1);
2177
else { bld_oint(op3, int_val(op2) | int_val(op1)); } ***/
2180
XSB_Start_Instr(and,_and) /* PRR */
2182
Op1(Register(get_xrx));
2184
ADVANCE_PC(size_xxx);
2188
if (isinteger(op1)) {
2189
if (isinteger(op2)) {
2190
Integer temp = (int_val(op2)) & (int_val(op1));
2191
bld_oint(op3, temp);
2193
else if (isboxedinteger(op2)) {
2194
Integer temp = (boxedint_val(op2)) & (int_val(op1));
2195
bld_oint(op3, temp);
2197
else {arithmetic_abort(CTXTc op2, "'/\\'", op1);}
2199
else if (isboxedinteger(op1)) {
2200
if (isinteger(op2)) {
2201
Integer temp = (int_val(op2)) & (boxedint_val(op1));
2202
bld_oint(op3, temp);
2204
else if (isboxedinteger(op2)) {
2205
Integer temp = (boxedint_val(op2)) & (boxedint_val(op1));
2206
bld_oint(op3, temp);
2208
else {arithmetic_abort(CTXTc op2, "'/\\'", op1);}
2210
else {arithmetic_abort(CTXTc op2, "'/\\'", op1);}
2212
/** if (!isinteger(op1) || !isinteger(op2)) {
2213
arithmetic_abort(CTXTc op2, "'/\\'", op1);
2215
else { bld_oint(op3, int_val(op2) & int_val(op1)); } **/
2218
XSB_Start_Instr(negate,_negate) /* PPR */
2221
ADVANCE_PC(size_xxx);
2224
if (isinteger(op1)) { bld_oint(op3, ~(int_val(op1))); }
2225
else if (isboxedinteger(op1)) {
2226
Integer temp = ~(boxedint_val(op1));
2227
bld_oint(op3, temp);
2229
else { arithmetic_abort1(CTXTc "'\\'", op1); }
2232
#ifndef JUMPTABLE_EMULOOP
2235
sprintf(message, "Illegal opcode hex %x", *lpcreg);
2238
} /* end of switch */
2243
sprintf(message, "Illegal opcode hex %x", *lpcreg);
2250
} /* end of emuloop() */
2252
/*======================================================================*/
2253
/*======================================================================*/
2255
DllExport int call_conv xsb(CTXTdeclc int flag, int argc, char *argv[])
2259
unsigned int magic_num;
2260
static double realtime; /* To retain its value across invocations */
2262
extern void dis(xsbBool);
2263
extern char *init_para(CTXTdeclc int, char **);
2264
extern void perform_IO_Redirect(CTXTdeclc int, char **);
2265
extern void init_machine(CTXTdeclc int, int, int, int), init_symbols(void);
2268
#ifndef FOREIGN_WIN32
2269
extern char tfile[];
2274
if (flag == 0) { /* initialize xsb */
2275
/* Set the name of the executable to the real name.
2276
The name of the executable could have been set in cinterf.c:xsb_init
2277
if XSB is called from C. In this case, we don't want `executable'
2278
to be overwritten, so we check if it is initialized. */
2280
perform_IO_Redirect(CTXTc argc, argv);
2283
strcpy(executable_path_gl,argv[0]);
2285
if (executable_path_gl[0] == '\0')
2286
xsb_executable_full_path(argv[0]);
2289
/* set install_dir, xsb_config_file and user_home */
2294
realtime = real_time();
2295
setbuf(stdout, NULL);
2296
startup_file = init_para(CTXTc argc, argv); /* init parameters */
2298
init_machine(CTXTc (int)NULL,(int)NULL,(int)NULL,(int)NULL); /* init space, regs, stacks */
2299
init_inst_table(); /* init table of instruction types */
2300
init_symbols(); /* preset a few symbols in PSC table */
2301
init_interrupt(); /* catch ^C interrupt signal */
2303
/* "b" does nothing in UNIX, denotes binary file in Windows --
2304
needed in Windows for reading byte-code files */
2305
fd = fopen(startup_file, "rb");
2309
sprintf(message, "The startup file, %s, could not be found!",
2313
magic_num = read_magic(fd);
2315
if (magic_num == 0x11121307 || magic_num == 0x11121305)
2316
inst_begin_gl = loader(CTXTc startup_file,0);
2318
xsb_exit("Incorrect startup file format");
2321
xsb_exit("Error in loading startup file");
2323
if (xsb_mode == DISASSEMBLE) {
2328
/* do it after initialization, so that typing
2329
xsb -v or xsb -h won't create .xsb directory */
2334
} else if (flag == 1) { /* continue execution */
2336
return(emuloop(CTXTc inst_begin_gl));
2338
} else if (flag == 2) { /* shutdown xsb */
2342
#ifndef FOREIGN_WIN32
2343
if (fopen(tfile, "r")) unlink(tfile);
2348
if (xsb_mode != C_CALLING_XSB) {
2349
realtime = real_time() - realtime;
2350
fprintf(stdmsg, "\nEnd XSB (cputime %.2f secs, elapsetime ",
2352
if (realtime < 600.0)
2353
fprintf(stdmsg, "%.2f secs)\n", realtime);
2355
fprintf(stdmsg, "%.2f mins)\n", realtime/60.0);
2360
} /* end of xsb() */
2362
/*======================================================================*/
added
removed
emu/emuloop.c
