00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027 #include "xsb_config.h"
00028 #include "xsb_debug.h"
00029
00030
00031 #include "debugs/debug_biassert.h"
00032 #include <stdio.h>
00033 #include <errno.h>
00034 #include <string.h>
00035 #include <stdlib.h>
00036
00037 #include "setjmp_xsb.h"
00038 #include "auxlry.h"
00039 #include "cell_xsb.h"
00040 #include "psc_xsb.h"
00041 #include "error_xsb.h"
00042 #include "cinterf.h"
00043 #include "memory_xsb.h"
00044 #include "heap_xsb.h"
00045 #include "register.h"
00046 #include "flags_xsb.h"
00047 #include "deref.h"
00048 #include "inst_xsb.h"
00049 #include "token_xsb.h"
00050 #include "loader_xsb.h"
00051 #include "trie_internals.h"
00052 #include "choice.h"
00053 #include "macro_xsb.h"
00054 #include "tr_utils.h"
00055 #include "trassert.h"
00056 #include "context.h"
00057 #include "thread_xsb.h"
00058 #include "debug_xsb.h"
00059 #include "biassert_defs.h"
00060
00061
00062
00063 extern Cell val_to_hash(Cell);
00064
00065 extern int xsb_profiling_enabled;
00066 extern void add_prog_seg(Psc, byte *, long);
00067 extern void remove_prog_seg(byte *);
00068 PrRef clref_to_prref(ClRef clref);
00069
00070 CPtr dbclause_cgc_block_gl = NULL;
00071 CPtr standard_cgc_block_begin_gl = NULL;
00072 CPtr standard_cgc_block_end_gl = NULL;
00073
00074
00075
00076
00077
00078 #define MARKED_FOR_DELETION 66
00079
00080 #define write_word(Buff,Loc,w) { *(CPtr)((pb)Buff + *(Loc)) = (Cell)(w); *(Loc) += 4; \
00081 pad64bits(Loc); }
00082 #define write_byte(Buff,Loc,w) { *(pb)((pb)Buff + *(Loc)) = (byte)(w); *(Loc) += 1; }
00083
00084 #ifdef BITS64
00085 #define pad64bits(Loc) { *(Loc) += 4; }
00086 #else
00087 #define pad64bits(Loc) {}
00088 #endif
00089
00090
00091 struct DispBlk_t {
00092 struct DispBlk_t *PrevDB;
00093 struct DispBlk_t *NextDB;
00094 int MaxThread;
00095 CPtr Thread0;
00096 };
00097
00098 struct DispBlkHdr_t {
00099 struct DispBlk_t *firstDB;
00100 struct DispBlk_t *lastDB;
00101 } DispBlkHdr = {NULL, NULL};
00102
00103 #ifdef MULTI_THREAD
00104
00105
00106
00107
00108 CPtr dynpredep_to_prortb(CTXTdeclc void *pred_ep) {
00109 if (th->tid > (((struct DispBlk_t **)pred_ep)[1])->MaxThread)
00110 xsb_abort("Dynamic Dispatch block too small");
00111 return (CPtr) ((&((struct DispBlk_t **)pred_ep)[1]->Thread0)[th->tid]);
00112 }
00113 #endif
00114
00115
00116
00117
00118
00119
00120
00121
00122 PrRef dynpredep_to_prref(CTXTdeclc void *pred_ep) {
00123 #ifdef MULTI_THREAD
00124 if (cell_opcode((CPtr)(pred_ep)) == switchonthread) {
00125 if (th->tid > (((struct DispBlk_t **)pred_ep)[1])->MaxThread)
00126 xsb_abort("Dynamic Dispatch block too small");
00127 pred_ep = (pb) (&((struct DispBlk_t **)pred_ep)[1]->Thread0)[th->tid];
00128 }
00129 if (!pred_ep) return NULL;
00130 #endif
00131 if (cell_opcode((CPtr)(pred_ep)) == tabletrysingle)
00132 return (PrRef)((CPtr *)(pred_ep))[6];
00133 else return pred_ep;
00134 }
00135
00136
00137
00138
00139
00140
00141
00142 static inline void dbgen_printinst3(Opcode, Arg1, Arg2, Arg3)
00143 {
00144 switch (Opcode) {
00145 case getlist_tvar_tvar:
00146 xsb_dbgmsg((LOG_ASSERT,"getlist_tvar_tvar - %ld %ld %ld",
00147 (long)Arg1,(long)Arg2,(long)Arg3)); break;
00148 case switchonbound:
00149 xsb_dbgmsg((LOG_ASSERT,"switchonbound - %ld %ld %ld",
00150 (long)Arg1,(long)Arg2,(long)Arg3)); break;
00151 case switchon3bound:
00152 xsb_dbgmsg((LOG_ASSERT,"switchon3bound - %ld %ld %ld",
00153 (long)Arg1,(long)Arg2,(long)Arg3)); break;
00154 default: xsb_dbgmsg((LOG_ASSERT,"Unknown instruction in assert %d",
00155 Opcode));
00156 }
00157 }
00158
00159 static inline void dbgen_printinst(Opcode, Arg1, Arg2)
00160 {
00161 switch (Opcode) {
00162 case getpvar:
00163 xsb_dbgmsg((LOG_ASSERT,"getpvar - %d %d\n", Arg1, Arg2)); break;
00164 case getpval:
00165 xsb_dbgmsg((LOG_ASSERT,"getpval - %d %d\n", Arg1, Arg2)); break;
00166 case putpvar:
00167 xsb_dbgmsg((LOG_ASSERT,"putpvar - %d %d\n", Arg1, Arg2)); break;
00168 case putpval:
00169 xsb_dbgmsg((LOG_ASSERT,"putpval - %d %d\n", Arg1, Arg2)); break;
00170 case gettval:
00171 xsb_dbgmsg((LOG_ASSERT,"gettval - %d %d\n", Arg1, Arg2)); break;
00172 case puttvar:
00173 xsb_dbgmsg((LOG_ASSERT,"puttvar - %d %d\n", Arg1, Arg2)); break;
00174 case movreg:
00175 xsb_dbgmsg((LOG_ASSERT,"movreg - %d %d\n", Arg1, Arg2)); break;
00176 case unipvar:
00177 xsb_dbgmsg((LOG_ASSERT,"unipvar - - %d\n", Arg1)); break;
00178 case unipval:
00179 xsb_dbgmsg((LOG_ASSERT,"unipval - - %d\n", Arg1)); break;
00180 case bldpvar:
00181 xsb_dbgmsg((LOG_ASSERT,"bldpvar - - %d\n", Arg1)); break;
00182 case bldpval:
00183 xsb_dbgmsg((LOG_ASSERT,"bldpval - - %d\n", Arg1)); break;
00184 case unitvar:
00185 xsb_dbgmsg((LOG_ASSERT,"unitvar - - %d\n", Arg1)); break;
00186 case uniavar:
00187 xsb_dbgmsg((LOG_ASSERT,"uniavar - - \n")); break;
00188 case unitval:
00189 xsb_dbgmsg((LOG_ASSERT,"unitval - - %d\n", Arg1)); break;
00190 case bldtvar:
00191 xsb_dbgmsg((LOG_ASSERT,"bldtvar - - %d\n", Arg1)); break;
00192 case bldavar:
00193 xsb_dbgmsg((LOG_ASSERT,"bldavar - - \n")); break;
00194 case bldtval:
00195 xsb_dbgmsg((LOG_ASSERT,"bldtval - - %d\n", Arg1)); break;
00196 case putlist:
00197 xsb_dbgmsg((LOG_ASSERT,"putlist - - %d\n", Arg1)); break;
00198 case getlist:
00199 xsb_dbgmsg((LOG_ASSERT,"getlist - - %d\n", Arg1)); break;
00200 case getattv:
00201 xsb_dbgmsg((LOG_ASSERT,"getattv - - %d\n", Arg1)); break;
00202 case putattv:
00203 xsb_dbgmsg((LOG_ASSERT,"putattv - - %d\n", Arg1)); break;
00204 case putcon:
00205 xsb_dbgmsg((LOG_ASSERT,"putcon - - %d 0x%x\n", Arg1, Arg2)); break;
00206 case putnumcon:
00207 xsb_dbgmsg((LOG_ASSERT,"putnumcon - - %d 0x%x\n", Arg1, int_val(Arg2))); break;
00208 case putfloat:
00209 xsb_dbgmsg((LOG_ASSERT,"putfloat - - %d %f (0x%x)\n", Arg1, ofloat_val(Arg2), ofloat_val(Arg2))); break;
00210 case getcon:
00211 xsb_dbgmsg((LOG_ASSERT,"getcon - - %d 0x%x\n", Arg1, Arg2)); break;
00212 case getnumcon:
00213 xsb_dbgmsg((LOG_ASSERT,"getnumcon - - %d 0x%x\n", Arg1, int_val(Arg2))); break;
00214 case getfloat:
00215 xsb_dbgmsg((LOG_ASSERT,"getfloat - - %d %f (0x%x)\n", Arg1, ofloat_val(Arg2), ofloat_val(Arg2))); break;
00216 case putstr:
00217 xsb_dbgmsg((LOG_ASSERT,"putstr - - %d 0x%x\n", Arg1, Arg2)); break;
00218 case getstr:
00219 xsb_dbgmsg((LOG_ASSERT,"getstr - - %d 0x%x\n", Arg1, Arg2)); break;
00220 case putnil:
00221 xsb_dbgmsg((LOG_ASSERT,"putnil - - %d\n", Arg1)); break;
00222 case getnil:
00223 xsb_dbgmsg((LOG_ASSERT,"getnil - - %d\n", Arg1)); break;
00224 case bldcon:
00225 xsb_dbgmsg((LOG_ASSERT,"bldcon - - - 0x%x\n", Arg1)); break;
00226 case bldnumcon:
00227 xsb_dbgmsg((LOG_ASSERT,"bldnumcon - - - 0x%x\n", int_val(Arg1))); break;
00228 case bldfloat:
00229 xsb_dbgmsg((LOG_ASSERT,"bldfloat - - - %f\n", ofloat_val(Arg1))); break;
00230 case unicon:
00231 xsb_dbgmsg((LOG_ASSERT,"unicon - - - 0x%x\n", Arg1)); break;
00232 case uninumcon:
00233 xsb_dbgmsg((LOG_ASSERT,"uninumcon - - - 0x%x\n", int_val(Arg1))); break;
00234 case unifloat:
00235 xsb_dbgmsg((LOG_ASSERT,"unifloat - - - %f\n", ofloat_val(Arg1))); break;
00236 case xsb_execute:
00237 xsb_dbgmsg((LOG_ASSERT,"execute - - - 0x%x\n", Arg1)); break;
00238 case bldnil:
00239 xsb_dbgmsg((LOG_ASSERT,"bldnil - - -\n")); break;
00240 case uninil:
00241 xsb_dbgmsg((LOG_ASSERT,"uninil - - -\n")); break;
00242 case proceed:
00243 xsb_dbgmsg((LOG_ASSERT,"proceed - - -\n")); break;
00244 case noop:
00245 xsb_dbgmsg((LOG_ASSERT,"noop - - -\n")); break;
00246 case dynnoop:
00247 xsb_dbgmsg((LOG_ASSERT,"dynnoop - - -\n")); break;
00248 case jumptbreg:
00249 xsb_dbgmsg((LOG_ASSERT,"jumptbreg - - %d 0x%x\n", Arg1, Arg2)); break;
00250 case test_heap:
00251 xsb_dbgmsg((LOG_ASSERT,"test_heap - - %d %d\n", Arg1, int_val(Arg2))); break;
00252 case dyntrustmeelsefail:
00253 xsb_dbgmsg((LOG_ASSERT,"dyntrustmeelsefail - - %d 0x%x\n", Arg1, Arg2)); break;
00254 case dynretrymeelse:
00255 xsb_dbgmsg((LOG_ASSERT,"dynretrymeelse - - %d 0x%x\n", Arg1, Arg2)); break;
00256 case dyntrymeelse:
00257 xsb_dbgmsg((LOG_ASSERT,"dyntrymeelse - - %d 0x%x\n", Arg1, Arg2)); break;
00258 case jump:
00259 xsb_dbgmsg((LOG_ASSERT,"jump - - - 0x%x\n", Arg1)); break;
00260 case fail:
00261 xsb_dbgmsg((LOG_ASSERT,"fail - - -\n")); break;
00262 default:
00263 xsb_dbgmsg((LOG_DEBUG, "Unknown instruction in assert %d",
00264 Opcode));
00265 }
00266 }
00267
00268 #define dbgen_printinst3_macro(Opcode, Arg1, Arg2, Arg3) \
00269 dbgen_printinst3(Opcode, Arg1, Arg2, Arg3)
00270
00271 #define dbgen_printinst_macro(Opcode, Arg1, Arg2) \
00272 dbgen_printinst(Opcode, Arg1, Arg2)
00273
00274
00275
00276
00277
00278
00279
00280
00281
00282 #define dbgen_inst3_tv(Opcode,Arg1,Arg2,Arg3,Buff,Loc) { \
00283 dbgen_printinst3_macro(Opcode, Arg1, Arg2, Arg3); \
00284 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,Arg1); \
00285 write_byte(Buff,Loc,Arg2); write_byte(Buff,Loc,Arg3); \
00286 pad64bits(Loc); \
00287 }
00288
00289 #define dbgen_inst3_sob(Opcode,Arg1,Arg2,Arg3,Buff,Loc) { \
00290 dbgen_printinst3_macro(Opcode, Arg1, Arg2, Arg3); \
00291 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,Arg1>>16); \
00292 write_byte(Buff,Loc,Arg1>>8); write_byte(Buff,Loc,Arg1); \
00293 pad64bits(Loc); \
00294 write_word(Buff,Loc,Arg2); write_word(Buff,Loc,Arg3); \
00295 }
00296
00297 #define dbgen_inst_pvv(Opcode,Arg1,Arg2,Buff,Loc) { \
00298 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00299 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00300 write_byte(Buff,Loc,Arg1); write_byte(Buff,Loc,Arg2); \
00301 pad64bits(Loc); \
00302 }
00303
00304 #define dbgen_inst_ppv(Opcode,Arg1,Buff,Loc) { \
00305 dbgen_printinst_macro(Opcode, Arg1, 0); \
00306 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00307 write_byte(Buff,Loc,0); write_byte(Buff,Loc,Arg1); \
00308 pad64bits(Loc); \
00309 }
00310
00311 #define dbgen_inst_ppvw(Opcode,Arg1,Arg2,Buff,Loc) { \
00312 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00313 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00314 write_byte(Buff,Loc,0); write_byte(Buff,Loc,Arg1); \
00315 pad64bits(Loc); \
00316 write_word(Buff,Loc,Arg2); \
00317 }
00318
00319 #define dbgen_inst_ppvw_safe(Opcode,Arg1,Arg2,Buff,Loc) { \
00320 int tLoc = 0, tempLoc = *Loc; char tBuff[4]; \
00321 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00322 *Loc += 4; \
00323 pad64bits(Loc); \
00324 write_word(Buff,Loc,Arg2); \
00325 write_byte(tBuff,&tLoc,Opcode); write_byte(tBuff,&tLoc,0); \
00326 write_byte(tBuff,&tLoc,0); write_byte(tBuff,&tLoc,Arg1); \
00327 memmove(Buff+tempLoc,tBuff,4); \
00328 }
00329
00330 #define dbgen_inst_ppvww(Opcode,Arg1,Arg2,Arg3,Buff,Loc) { \
00331 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00332 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00333 write_byte(Buff,Loc,0); write_byte(Buff,Loc,Arg1); \
00334 pad64bits(Loc); \
00335 write_word(Buff,Loc,Arg2); \
00336 write_word(Buff,Loc,Arg3); \
00337 }
00338
00339 #define dbgen_inst_pppw(Opcode,Arg1,Buff,Loc) { \
00340 dbgen_printinst_macro(Opcode, (Integer)Arg1, 0); \
00341 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00342 write_byte(Buff,Loc,0); write_byte(Buff,Loc,0); \
00343 pad64bits(Loc); \
00344 write_word(Buff,Loc,Arg1); \
00345 }
00346
00347 #define dbgen_inst_ppp(Opcode,Buff,Loc) { \
00348 dbgen_printinst_macro(Opcode, 0, 0); \
00349 write_byte(Buff,Loc,Opcode); write_byte(Buff,Loc,0); \
00350 write_byte(Buff,Loc,0); write_byte(Buff,Loc,0); \
00351 pad64bits(Loc); \
00352 }
00353
00354 #define dbgen_instB3_tv(Opcode,Arg1,Arg2,Arg3) { \
00355 dbgen_printinst3_macro(Opcode, Arg1, Arg2, Arg3); \
00356 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00357 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1); \
00358 write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg2); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg3); \
00359 pad64bits(asrtBuff->Loc); \
00360 }
00361
00362 #define dbgen_instB3_sob(Opcode,Arg1,Arg2,Arg3) { \
00363 dbgen_printinst3_macro(Opcode, Arg1, Arg2, Arg3); \
00364 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00365 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1>>16); \
00366 write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1>>8); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1); \
00367 pad64bits(asrtBuff->Loc); \
00368 write_word(asrtBuff->Buff,asrtBuff->Loc,Arg2); write_word(asrtBuff->Buff,asrtBuff->Loc,Arg3); \
00369 }
00370
00371 #define dbgen_instB_pvv(Opcode,Arg1,Arg2) { \
00372 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00373 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00374 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00375 write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg2); \
00376 pad64bits(asrtBuff->Loc); \
00377 }
00378
00379 #define dbgen_instB_ppv(Opcode,Arg1) { \
00380 dbgen_printinst_macro(Opcode, Arg1,0); \
00381 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00382 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00383 write_byte(asrtBuff->Buff,asrtBuff->Loc,0); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1); \
00384 pad64bits(asrtBuff->Loc); \
00385 }
00386
00387 #define dbgen_instB_ppvw(Opcode,Arg1,Arg2) { \
00388 dbgen_printinst_macro(Opcode, Arg1, (Integer)Arg2); \
00389 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00390 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00391 write_byte(asrtBuff->Buff,asrtBuff->Loc,0); write_byte(asrtBuff->Buff,asrtBuff->Loc,Arg1); \
00392 pad64bits(asrtBuff->Loc); \
00393 write_word(asrtBuff->Buff,asrtBuff->Loc,Arg2); \
00394 }
00395
00396 #define dbgen_instB_pppw(Opcode,Arg1) { \
00397 dbgen_printinst_macro(Opcode, (Integer)Arg1, 0); \
00398 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00399 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00400 write_byte(asrtBuff->Buff,asrtBuff->Loc,0); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00401 pad64bits(asrtBuff->Loc); \
00402 write_word(asrtBuff->Buff,asrtBuff->Loc,Arg1); \
00403 }
00404
00405 #define dbgen_instB_ppp(Opcode) { \
00406 dbgen_printinst_macro(Opcode,0,0); \
00407 if (*asrtBuff->Loc >= asrtBuff->BLim) asrtBuff->Buff = buff_realloc(CTXT); \
00408 write_byte(asrtBuff->Buff,asrtBuff->Loc,Opcode); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00409 write_byte(asrtBuff->Buff,asrtBuff->Loc,0); write_byte(asrtBuff->Buff,asrtBuff->Loc,0); \
00410 pad64bits(asrtBuff->Loc); \
00411 }
00412
00413
00414
00415
00416
00417
00418
00419
00420
00421
00422
00423
00424
00425
00426
00427 #ifndef MULTI_THREAD
00428 static jmp_buf assertcmp_env;
00429 #endif
00430
00431 struct flatten_elt {
00432 union {
00433 prolog_term term;
00434 Cell opcode;
00435 } v;
00436 int _reg;
00437 };
00438
00439 #define FLATTEN_STACK_SIZE 512
00440
00441 struct flatten_q {
00442 int flatten_stack_top;
00443 struct flatten_elt flatten_stack[FLATTEN_STACK_SIZE];
00444 };
00445
00446
00447 #define INST_QUEUE_SIZE 512
00448
00449 struct instruction {
00450 Cell opcode;
00451 Cell arg1;
00452 Cell arg2;
00453 };
00454
00455 struct instruction_q {
00456 int inst_queue_top;
00457 int inst_queue_bottom;
00458 int inst_queue_added;
00459 struct instruction inst_queue[INST_QUEUE_SIZE];
00460 };
00461
00462 static void assertcmp_throw(CTXTdeclc int num)
00463 {
00464 longjmp(assertcmp_env, num);
00465 }
00466
00467
00468 #define ERR_FUNCTOR 1
00469 #define ERR_REGISTER 2
00470
00471 static int arity(CTXTdeclc prolog_term T0)
00472 {
00473 if (isconstr(T0)) return p2c_arity(T0);
00474 else if (islist(T0)) return 2;
00475 else if (isstring(T0)) return 0;
00476 else assertcmp_throw(CTXTc ERR_FUNCTOR);
00477 return -1;
00478 }
00479
00480 static void assertcmp_printerror(CTXTdeclc int num)
00481 {
00482 switch (num) {
00483 case ERR_FUNCTOR:
00484 xsb_abort("[Assert] functor expected");
00485 break;
00486 case ERR_REGISTER:
00487 xsb_abort("[Assert] need too many registers");
00488 break;
00489 default:
00490 xsb_abort("[Assert] error occured in assert_cmp");
00491 }
00492 }
00493
00494
00495
00496 static Integer p2c_float_as_int(prolog_term T0)
00497 {
00498
00499
00500
00501
00502
00503 FloatConv converter;
00504 converter.f = (float)ofloat_val(T0);
00505 return converter.i;
00506 }
00507
00508 static int is_frozen_var(prolog_term T0)
00509 {
00510 if (isconstr(T0) && strcmp(p2c_functor(T0), "$assertVAR")==0 &&
00511 p2c_arity(T0) == 1) {
00512 T0 = p2p_arg(T0, 1);
00513 return int_val(T0);
00514 } else return 0;
00515 }
00516
00517 static void flatten_stack_init(struct flatten_q *flatten_stackq)
00518 {
00519 flatten_stackq->flatten_stack_top = 0;
00520 }
00521
00522 static int flatten_stack_size(struct flatten_q *flatten_stackq)
00523 {
00524 return flatten_stackq->flatten_stack_top;
00525 }
00526
00527 static void flatten_stack_push(struct flatten_q *flatten_stackq,
00528 int argno, Cell term)
00529 {
00530 flatten_stackq->flatten_stack[flatten_stackq->flatten_stack_top]._reg = argno;
00531 flatten_stackq->flatten_stack[flatten_stackq->flatten_stack_top].v.opcode = term;
00532 flatten_stackq->flatten_stack_top++;
00533 if (flatten_stackq->flatten_stack_top >= FLATTEN_STACK_SIZE)
00534 xsb_abort("flatten_stack overflow in assert");
00535 }
00536
00537 static void flatten_stack_pop(struct flatten_q *flatten_stackq,
00538 int *argnop, Cell *termp)
00539 {
00540 flatten_stackq->flatten_stack_top--;
00541 *argnop = flatten_stackq->flatten_stack[flatten_stackq->flatten_stack_top]._reg;
00542 *termp = flatten_stackq->flatten_stack[flatten_stackq->flatten_stack_top].v.opcode;
00543 }
00544
00545 static void inst_queue_init(struct instruction_q *inst_queue)
00546 {
00547 inst_queue->inst_queue_top = inst_queue->inst_queue_bottom = 10;
00548 }
00549
00550 static int inst_queue_empty(struct instruction_q *inst_queue)
00551 {
00552 return (inst_queue->inst_queue_top == inst_queue->inst_queue_bottom);
00553 }
00554
00555 static void inst_queue_push(struct instruction_q *inst_queue,
00556 Cell opcode, Cell arg1, Cell arg2)
00557 {
00558 inst_queue->inst_queue[inst_queue->inst_queue_top].opcode = opcode;
00559 inst_queue->inst_queue[inst_queue->inst_queue_top].arg1 = arg1;
00560 inst_queue->inst_queue[inst_queue->inst_queue_top].arg2 = arg2;
00561 inst_queue->inst_queue_top = (inst_queue->inst_queue_top+1) % INST_QUEUE_SIZE;
00562 if (inst_queue->inst_queue_top == inst_queue->inst_queue_bottom)
00563 xsb_abort("instruction queue overflow in assert");
00564 }
00565
00566 static void inst_queue_pop(struct instruction_q *inst_queue,
00567 Cell *opcodep, Cell *arg1p, Cell *arg2p)
00568 {
00569 if (inst_queue->inst_queue_top == 0) inst_queue->inst_queue_top = INST_QUEUE_SIZE;
00570 inst_queue->inst_queue_top--;
00571 *opcodep = inst_queue->inst_queue[inst_queue->inst_queue_top].opcode;
00572 *arg1p = inst_queue->inst_queue[inst_queue->inst_queue_top].arg1;
00573 *arg2p = inst_queue->inst_queue[inst_queue->inst_queue_top].arg2;
00574 }
00575
00576 static void inst_queue_rem(struct instruction_q *inst_queue,
00577 Cell *opcodep, Cell *arg1p, Cell *arg2p)
00578 {
00579 *opcodep = inst_queue->inst_queue[inst_queue->inst_queue_bottom].opcode;
00580 *arg1p = inst_queue->inst_queue[inst_queue->inst_queue_bottom].arg1;
00581 *arg2p = inst_queue->inst_queue[inst_queue->inst_queue_bottom].arg2;
00582 inst_queue->inst_queue_bottom = (inst_queue->inst_queue_bottom+1) % INST_QUEUE_SIZE;
00583 }
00584
00585 static void inst_queue_add(struct instruction_q *inst_queue,
00586 Cell opcodep, Cell arg1p, Cell arg2p)
00587 {
00588 if (inst_queue->inst_queue_bottom == 0) inst_queue->inst_queue_bottom = INST_QUEUE_SIZE;
00589 inst_queue->inst_queue_bottom--;
00590 if (inst_queue->inst_queue_top == inst_queue->inst_queue_bottom)
00591 xsb_abort("instruction queue overflow in assert");
00592 inst_queue->inst_queue[inst_queue->inst_queue_bottom].opcode = opcodep;
00593 inst_queue->inst_queue[inst_queue->inst_queue_bottom].arg1 = arg1p;
00594 inst_queue->inst_queue[inst_queue->inst_queue_bottom].arg2 = arg2p;
00595 inst_queue->inst_queue_added++;
00596 }
00597
00598 static void inst_queue_rotate(struct instruction_q *inst_queue) {
00599 prolog_term T0, T1;
00600 Cell Argno;
00601 while (inst_queue->inst_queue_added--) {
00602 inst_queue_rem(inst_queue,&Argno,&T0,&T1);
00603 inst_queue_push(inst_queue,Argno,T0,T1);
00604 }
00605 }
00606
00607
00608
00609
00610
00611
00612
00613 #define RVAR -1
00614 #define TVAR -2
00615
00616 struct RegStat_t {
00617 int RegArray[MAX_REGS];
00618 int RegArrayInit[MAX_REGS];
00619 int FreeReg;
00620 };
00621
00622 typedef struct RegStat_t *RegStat;
00623
00624 static void reg_init(RegStat Reg, int Size)
00625 {
00626 int i;
00627
00628 Reg->FreeReg = Size+1;
00629 for (i=0; i<Reg->FreeReg; i++) Reg->RegArray[i] = RVAR;
00630 Reg->RegArray[Reg->FreeReg] = 0;
00631 }
00632
00633
00634 static int reg_get(CTXTdeclc RegStat Reg, int Type)
00635 {
00636 int new_reg;
00637
00638 new_reg = Reg->FreeReg;
00639 if (Reg->RegArray[Reg->FreeReg]==0) {
00640 Reg->FreeReg++;
00641 if (Reg->FreeReg >= MAX_REGS) {
00642 assertcmp_throw(CTXTc ERR_REGISTER);
00643 }
00644 Reg->RegArray[Reg->FreeReg] = 0;
00645 } else Reg->FreeReg = Reg->RegArray[Reg->FreeReg];
00646 Reg->RegArray[new_reg] = Type;
00647 Reg->RegArrayInit[new_reg] = 0;
00648 return new_reg;
00649 }
00650
00651 static void reg_release(RegStat Reg, int R0)
00652 {
00653 if (Reg->RegArray[R0]==TVAR) {
00654 Reg->RegArray[R0] = Reg->FreeReg;
00655 Reg->FreeReg = R0;
00656 }
00657 }
00658
00659 #ifndef MULTI_THREAD
00660 struct asrtBuff_t asrtBuffB = {NULL,512,NULL,0,0};
00661 struct asrtBuff_t *asrtBuff = &asrtBuffB;
00662 #endif
00663
00664 static char *buff_realloc(CTXTdecl)
00665 {
00666
00667 asrtBuff->Buff_size = asrtBuff->Buff_size + asrtBuff->Buff_size;
00668 if (asrtBuff->Buff == NULL) asrtBuff->Buff = (char *)mem_alloc(asrtBuff->Buff_size,ASSERT_SPACE);
00669 else asrtBuff->Buff = (char *)mem_realloc(asrtBuff->Buff,(asrtBuff->Buff_size / 2),asrtBuff->Buff_size,ASSERT_SPACE);
00670 asrtBuff->BLim = asrtBuff->Buff_size-16;
00671
00672 return(asrtBuff->Buff);
00673 }
00674
00675
00676
00677
00678
00679 static void db_genmvs(CTXTdeclc struct instruction_q *, RegStat);
00680 static void db_putterm(CTXTdeclc int, prolog_term, RegStat, struct flatten_q *);
00681 static void db_gentopinst(CTXTdeclc prolog_term, int, RegStat);
00682 static void db_genterms(CTXTdeclc struct instruction_q *, RegStat);
00683 static void db_geninst(CTXTdeclc prolog_term, RegStat, struct instruction_q *);
00684 static void db_bldsubs(CTXTdeclc prolog_term, RegStat, struct flatten_q *);
00685 static void db_genaput(CTXTdeclc prolog_term, int, struct instruction_q *, RegStat);
00686
00687
00688
00689
00690
00691
00692
00693
00694 int assert_code_to_buff_p(CTXTdeclc prolog_term);
00695
00696 int assert_code_to_buff( CTXTdecl )
00697 {
00698 return assert_code_to_buff_p(CTXTc reg_term(CTXTc 1));
00699 }
00700
00701 int assert_code_to_buff_p(CTXTdeclc prolog_term Clause)
00702 {
00703 prolog_term Head, Body;
00704 int Location;
00705 int Loc_size;
00706 struct RegStat_t Reg_lc;
00707 RegStat Reg = &Reg_lc;
00708 int Arity;
00709 int has_body;
00710 int Argno;
00711 int v;
00712 Pair sym;
00713 struct instruction_q inst_queue_lc;
00714 struct instruction_q *inst_queue = &inst_queue_lc;
00715
00716
00717 if ((Argno = setjmp(assertcmp_env))) {
00718 assertcmp_printerror(CTXTc Argno);
00719 return FALSE;
00720 }
00721 if (isconstr(Clause) && get_str_psc(Clause)==if_psc) {
00722 Head = p2p_arg(Clause, 1);
00723 Body = p2p_arg(Clause, 2);
00724 has_body = 1;
00725 if (isstring(Body)) {
00726 if (string_val(Body) == true_string) has_body = 0;
00727 else {
00728 sym = insert(string_val(Body),0,(Psc)flags[CURRENT_MODULE],&v);
00729 Body = makecs(hreg);
00730 new_heap_functor(hreg,sym->psc_ptr);
00731 }
00732 }
00733 } else {
00734 Head = Clause;
00735 Body = (prolog_term) NULL;
00736 has_body = 0;
00737 }
00738 Arity = arity(CTXTc Head);
00739 Location = 0;
00740 asrtBuff->Loc = &Location;
00741 dbgen_instB_ppvw(test_heap,Arity,0);
00742 Loc_size = *asrtBuff->Loc - sizeof(Cell);
00743 if (has_body) reg_init(Reg,xsb_max(Arity,(int)get_arity(get_str_psc(Body))));
00744 else reg_init(Reg,Arity);
00745 inst_queue_init(inst_queue);
00746 for (Argno = 1; Argno <= Arity; Argno++) {
00747 db_gentopinst(CTXTc p2p_arg(Head,Argno),Argno,Reg);
00748 }
00749 if (has_body) {
00750 inst_queue_init(inst_queue);
00751 for (Argno=1; Argno<=arity(CTXTc Body); Argno++) {
00752 db_genaput(CTXTc p2p_arg(Body,Argno),Argno,inst_queue,Reg);
00753 }
00754 db_genmvs(CTXTc inst_queue,Reg);
00755 dbgen_instB_pppw(xsb_execute, get_str_psc(Body));
00756 } else dbgen_instB_ppp(proceed);
00757 asrtBuff->Size = *asrtBuff->Loc;
00758 write_word(asrtBuff->Buff,&Loc_size,(asrtBuff->Size/sizeof(Cell)));
00759
00760 return TRUE;
00761 }
00762
00763 static void db_gentopinst(CTXTdeclc prolog_term T0, int Argno, RegStat Reg)
00764 {
00765 int Rt;
00766 struct instruction_q inst_queue_lc;
00767 struct instruction_q *inst_queue = &inst_queue_lc;
00768
00769 if (isinteger(T0)) {
00770 dbgen_instB_ppvw(getnumcon, Argno, int_val(T0));
00771 } else if (isstring(T0)) {
00772 if (strcmp(string_val(T0),"$assertAVAR"))
00773 dbgen_instB_ppvw(getcon, Argno, (Cell)string_val(T0));
00774 } else if (isfloat(T0)) {
00775 dbgen_instB_ppvw(getfloat, Argno, T0);
00776 } else if (isref(T0)) {
00777 c2p_functor(CTXTc "$assertVAR", 1, T0);
00778 T0 = p2p_arg(T0, 1);
00779 c2p_int(CTXTc Argno, T0);
00780 Reg->RegArrayInit[Argno] = 1;
00781 } else if (isnil(T0)) {
00782 dbgen_instB_ppv(getnil, Argno);
00783 } else if ((Rt = is_frozen_var(T0))) {
00784 dbgen_instB_pvv(gettval, Rt, Argno);
00785 } else {
00786 inst_queue_init(inst_queue);
00787 inst_queue_push(inst_queue, Argno, T0, 0);
00788 if (isattv(T0)) {
00789 T0 = p2p_arg(T0, 0);
00790 c2p_functor(CTXTc "$assertVAR", 1, T0);
00791 T0 = p2p_arg(T0, 1);
00792 c2p_int(CTXTc Argno, T0);
00793 Reg->RegArrayInit[Argno] = 1;
00794 }
00795 db_genterms(CTXTc inst_queue, Reg);
00796 }
00797 }
00798
00799 static void db_genterms(CTXTdeclc struct instruction_q *inst_queue,
00800 RegStat Reg)
00801 {
00802 prolog_term T0, T1, T2;
00803 Cell Argno;
00804
00805 while (!inst_queue_empty(inst_queue)) {
00806 inst_queue_pop(inst_queue, &Argno, &T0, &T1);
00807 Reg->RegArrayInit[Argno] = 1;
00808 if (islist(T0)) {
00809 T1 = p2p_car(T0);
00810 T2 = p2p_cdr(T0);
00811 if (isref(T1) && isref(T2) && T1!=T2 ) {
00812 int Rt1, Rt2;
00813 c2p_functor(CTXTc "$assertVAR", 1, T1);
00814 T1 = p2p_arg(T1, 1);
00815 Rt1 = reg_get(CTXTc Reg, RVAR);
00816 c2p_int(CTXTc Rt1, T1);
00817 c2p_functor(CTXTc "$assertVAR", 1, T2);
00818 T2 = p2p_arg(T2, 1);
00819 Rt2 = reg_get(CTXTc Reg, RVAR);
00820 c2p_int(CTXTc Rt2, T2);
00821 dbgen_instB3_tv(getlist_tvar_tvar, Argno, Rt1, Rt2);
00822 Reg->RegArrayInit[Rt1] = 1;
00823 Reg->RegArrayInit[Rt2] = 1;
00824 reg_release(Reg,Argno);
00825 } else {
00826 dbgen_instB_ppv(getlist, Argno);
00827 reg_release(Reg,Argno);
00828 inst_queue->inst_queue_added = 0;
00829 db_geninst(CTXTc p2p_car(T0), Reg, inst_queue);
00830 db_geninst(CTXTc p2p_cdr(T0), Reg, inst_queue);
00831 inst_queue_rotate(inst_queue);
00832 }
00833 } else if (isconstr(T0)) {
00834 dbgen_instB_ppvw(getstr, Argno, get_str_psc(T0));
00835 reg_release(Reg,Argno);
00836 inst_queue->inst_queue_added = 0;
00837 for (Argno=1; Argno <= (int)get_arity(get_str_psc(T0)); Argno++) {
00838 db_geninst(CTXTc p2p_arg(T0,Argno), Reg, inst_queue);
00839 }
00840 inst_queue_rotate(inst_queue);
00841 }
00842 else {
00843 T1 = cell(clref_val(T0) + 1);
00844 XSB_Deref(T1);
00845 dbgen_instB_ppv(getattv, Argno);
00846
00847
00848 db_geninst(CTXTc T1, Reg, inst_queue);
00849 }
00850 }
00851 }
00852
00853 static void db_geninst(CTXTdeclc prolog_term Sub, RegStat Reg,
00854 struct instruction_q *inst_queue)
00855 {
00856 int Rt;
00857
00858 if (isinteger(Sub)) {
00859 dbgen_instB_pppw(uninumcon, int_val(Sub));
00860 } else if (isstring(Sub)) {
00861 if (!strcmp(string_val(Sub),"$assertAVAR")) {
00862 dbgen_instB_ppp(uniavar);
00863 } else dbgen_instB_pppw(unicon, (Cell)p2c_string(Sub));
00864 } else if (isnil(Sub)) {
00865 dbgen_instB_ppp(uninil);
00866 } else if (isfloat(Sub)) {
00867 dbgen_instB_pppw(unifloat, Sub);
00868 } else if (isref(Sub)) {
00869 c2p_functor(CTXTc "$assertVAR", 1, Sub);
00870 Sub = p2p_arg(Sub, 1);
00871 Rt = reg_get(CTXTc Reg, RVAR);
00872 c2p_int(CTXTc Rt, Sub);
00873 dbgen_instB_ppv(unitvar, Rt);
00874 Reg->RegArrayInit[Rt] = 1;
00875 } else if ((Rt = is_frozen_var(Sub))) {
00876 dbgen_instB_ppv(unitval, Rt);
00877 } else if (isattv(Sub)) {
00878
00879
00880
00881
00882 Rt = reg_get(CTXTc Reg, RVAR);
00883 dbgen_instB_ppv(unitvar, Rt);
00884 Reg->RegArrayInit[Rt] = 1;
00885 inst_queue_add(inst_queue, Rt, Sub, 0);
00886
00887 Sub = p2p_arg(Sub, 0);
00888 c2p_functor(CTXTc "$assertVAR", 1, Sub);
00889 Sub = p2p_arg(Sub, 1);
00890 c2p_int(CTXTc Rt, Sub);
00891 } else {
00892 Rt = reg_get(CTXTc Reg, TVAR);
00893 dbgen_instB_ppv(unitvar, Rt);
00894 Reg->RegArrayInit[Rt] = 1;
00895 inst_queue_add(inst_queue, Rt, Sub, 0);
00896 }
00897 }
00898
00899 static void db_genaput(CTXTdeclc prolog_term T0, int Argno,
00900 struct instruction_q *inst_queue,
00901 RegStat Reg)
00902 {
00903 int Rt;
00904 struct flatten_q flatten_stack_lc;
00905 struct flatten_q *flatten_stackq = &flatten_stack_lc;
00906
00907 if (isref(T0)) {
00908 c2p_functor(CTXTc "$assertVAR", 1, T0);
00909 T0 = p2p_arg(T0, 1);
00910 Rt = reg_get(CTXTc Reg, RVAR);
00911 c2p_int(CTXTc Rt, T0);
00912 dbgen_instB_pvv(puttvar, Rt, Rt);
00913 Reg->RegArrayInit[Rt] = 1;
00914 inst_queue_push(inst_queue, movreg, Rt, Argno);
00915 } else if ((Rt = is_frozen_var(T0))) {
00916 inst_queue_push(inst_queue, movreg, Rt, Argno);
00917 } else if (isinteger(T0)) {
00918 inst_queue_push(inst_queue, putnumcon, int_val(T0), Argno);
00919 } else if (isfloat(T0)) {
00920 inst_queue_push(inst_queue, putnumcon, p2c_float_as_int(T0),
00921 Argno);
00922 } else if (isnil(T0)) {
00923 inst_queue_push(inst_queue, putnil, 0, Argno);
00924 } else if (isstring(T0)) {
00925 if (!strcmp(string_val(T0),"$assertAVAR")) {
00926 Rt = reg_get(CTXTc Reg, RVAR);
00927 dbgen_instB_pvv(puttvar, Rt, Rt);
00928 Reg->RegArrayInit[Rt] = 1;
00929 inst_queue_push(inst_queue, movreg, Rt, Argno);
00930 } else inst_queue_push(inst_queue, putcon, (Cell)p2c_string(T0), Argno);
00931 } else if (isattv(T0)) {
00932 prolog_term T1;
00933
00934 Rt = reg_get(CTXTc Reg, RVAR);
00935 inst_queue_push(inst_queue, movreg, Rt, Argno);
00936 flatten_stack_init(flatten_stackq);
00937
00938 T1 = p2p_arg(T0, 0);
00939 c2p_functor(CTXTc "$assertVAR", 1, T1);
00940 T1 = p2p_arg(T1, 1);
00941 c2p_int(CTXTc Rt, T1);
00942 Reg->RegArrayInit[Rt] = 1;
00943
00944 db_putterm(CTXTc Rt,T0,Reg,flatten_stackq);
00945 } else {
00946 Rt = reg_get(CTXTc Reg, TVAR);
00947 inst_queue_push(inst_queue, movreg, Rt, Argno);
00948 flatten_stack_init(flatten_stackq);
00949 db_putterm(CTXTc Rt,T0,Reg,flatten_stackq);
00950 }
00951 }
00952
00953 static void db_putterm(CTXTdeclc int Rt, prolog_term T0,
00954 RegStat Reg, struct flatten_q *flatten_stackq)
00955 {
00956 int Argno;
00957 int BldOpcode;
00958 Cell Arg1;
00959 int stack_size;
00960
00961 stack_size = flatten_stack_size(flatten_stackq);
00962 if (islist(T0)) {
00963 db_bldsubs(CTXTc p2p_cdr(T0),Reg,flatten_stackq);
00964 db_bldsubs(CTXTc p2p_car(T0),Reg,flatten_stackq);
00965 dbgen_instB_ppv(putlist, Rt);
00966 } else if (isconstr(T0)) {
00967 for (Argno=get_arity(get_str_psc(T0)); Argno>=1; Argno--)
00968 db_bldsubs(CTXTc p2p_arg(T0,Argno),Reg,flatten_stackq);
00969 dbgen_instB_ppvw(putstr, Rt, get_str_psc(T0));
00970 } else {
00971 db_bldsubs(CTXTc cell(clref_val(T0)+1), Reg, flatten_stackq);
00972 dbgen_instB_ppv(putattv, Rt);
00973 }
00974 Reg->RegArrayInit[Rt] = 1;
00975 while (flatten_stack_size(flatten_stackq)>stack_size) {
00976 flatten_stack_pop(flatten_stackq, &BldOpcode, &Arg1);
00977
00978 switch (BldOpcode) {
00979 case bldpvar:
00980 if (Reg->RegArrayInit[Arg1]) {
00981 dbgen_instB_ppv(bldpval, Arg1); break;
00982 } else {
00983 Reg->RegArrayInit[Arg1] = 1;
00984 dbgen_instB_ppv(bldpvar, Arg1); break;
00985 }
00986 case bldtvar:
00987 if (Reg->RegArrayInit[Arg1]) {
00988 dbgen_instB_ppv(bldtval, Arg1);
00989 } else {
00990 Reg->RegArrayInit[Arg1] = 1;
00991 dbgen_instB_ppv(bldtvar, Arg1);
00992 }
00993 break;
00994 case bldavar:
00995 dbgen_instB_ppp(bldavar); break;
00996 case bldcon:
00997 dbgen_instB_pppw(bldcon, Arg1); break;
00998 case bldnumcon:
00999 dbgen_instB_pppw(bldnumcon, Arg1); break;
01000 case bldfloat:
01001 dbgen_instB_pppw(bldfloat, Arg1); break;
01002 case bldnil:
01003 dbgen_instB_ppp(bldnil); break;
01004 default:
01005 xsb_dbgmsg((LOG_DEBUG,"Incorrect bld instruction in assert %d",
01006 BldOpcode));
01007 }
01008 }
01009 }
01010
01011 static void db_bldsubs(CTXTdeclc prolog_term Sub, RegStat Reg,
01012 struct flatten_q *flatten_stackq)
01013 {
01014 int Rt;
01015
01016 if (isstring(Sub)) {
01017 if (!strcmp(string_val(Sub),"$assertAVAR"))
01018 flatten_stack_push(flatten_stackq, bldavar, 0);
01019 else flatten_stack_push(flatten_stackq,bldcon,(Cell)string_val(Sub));
01020 } else if (isinteger(Sub)) {
01021 flatten_stack_push(flatten_stackq, bldnumcon, int_val(Sub));
01022 } else if (isfloat(Sub)) {
01023 flatten_stack_push(flatten_stackq, bldfloat, Sub);
01024 } else if (isref(Sub)) {
01025 c2p_functor(CTXTc "$assertVAR", 1, Sub);
01026 Sub = p2p_arg(Sub, 1);
01027 Rt = reg_get(CTXTc Reg, RVAR);
01028 c2p_int(CTXTc Rt, Sub);
01029 flatten_stack_push(flatten_stackq, bldtvar, Rt);
01030 } else if (isnil(Sub)) {
01031 flatten_stack_push(flatten_stackq, bldnil, 0);
01032 } else if ((Rt = is_frozen_var(Sub))) {
01033 flatten_stack_push(flatten_stackq, bldtvar, Rt);
01034 } else if (isattv(Sub)) {
01035 prolog_term T1;
01036
01037 Rt = reg_get(CTXTc Reg, RVAR);
01038 flatten_stack_push(flatten_stackq, bldtvar, Rt);
01039
01040 T1 = p2p_arg(Sub, 0);
01041 c2p_functor(CTXTc "$assertVAR", 1, T1);
01042 T1 = p2p_arg(T1, 1);
01043 c2p_int(CTXTc Rt, T1);
01044
01045
01046
01047 db_putterm(CTXTc Rt, Sub, Reg, flatten_stackq);
01048 } else {
01049 Rt = reg_get(CTXTc Reg, TVAR);
01050 flatten_stack_push(flatten_stackq, bldtvar, Rt);
01051 db_putterm(CTXTc Rt,Sub,Reg,flatten_stackq);
01052 }
01053 }
01054
01055 static xsbBool target_is_not_source(struct instruction_q *inst_queue, int Reg)
01056 {
01057 int i;
01058
01059 for (i=inst_queue->inst_queue_bottom; i<inst_queue->inst_queue_top; i++) {
01060 if (inst_queue->inst_queue[i].opcode==movreg && (int)inst_queue->inst_queue[i].arg1 == Reg)
01061 return FALSE;
01062 }
01063 return TRUE;
01064 }
01065
01066 static xsbBool source_is_not_target(struct instruction_q *inst_queue, int Reg)
01067 {
01068 int i;
01069
01070 for (i=inst_queue->inst_queue_bottom; i<inst_queue->inst_queue_top; i++) {
01071 if ((int)inst_queue->inst_queue[i].arg2 == Reg) return FALSE;
01072 }
01073 return TRUE;
01074 }
01075
01076
01077
01078
01079
01080
01081
01082
01083
01084
01085 static void db_genmvs(CTXTdeclc struct instruction_q *inst_queue, RegStat Reg)
01086 {
01087 Cell Opcode, Arg, T0, R0;
01088
01089
01090 while (!inst_queue_empty(inst_queue)) {
01091 inst_queue_rem(inst_queue, &Opcode, &Arg, &T0);
01092 switch (Opcode) {
01093 case puttvar:
01094 dbgen_instB_pvv(Opcode, Arg, T0);
01095 break;
01096 case putnil:
01097 if (target_is_not_source(inst_queue,T0))
01098 {dbgen_instB_ppv(Opcode, T0);}
01099 else inst_queue_push(inst_queue, Opcode, Arg, T0);
01100 break;
01101 case putcon:
01102 case putnumcon:
01103 if (target_is_not_source(inst_queue,T0))
01104 {dbgen_instB_ppvw(Opcode, T0, Arg);}
01105 else inst_queue_push(inst_queue, Opcode, Arg, T0);
01106 break;
01107 case movreg:
01108 if (Arg==T0) break;
01109 else if (target_is_not_source(inst_queue,T0)) {
01110 dbgen_instB_pvv(movreg, Arg, T0);
01111 reg_release(Reg,Arg);
01112 } else if (source_is_not_target(inst_queue,Arg))
01113 inst_queue_push(inst_queue, movreg, Arg, T0);
01114
01115
01116 else {
01117 R0 = reg_get(CTXTc Reg, TVAR);
01118 dbgen_instB_pvv(movreg, Arg, R0);
01119 reg_release(Reg,Arg);
01120 inst_queue_push(inst_queue, movreg, R0, T0);
01121
01122 }
01123 break;
01124 }
01125 }
01126 }
01127
01128
01129
01130
01131
01132
01133
01134
01135
01136
01137
01138
01139
01140
01141
01142
01143
01144
01145
01146
01147
01148
01149
01150
01151
01152
01153
01154
01155
01156
01157
01158
01159
01160
01161
01162
01163
01164
01165
01166
01167
01168
01169
01170
01171
01172
01173
01174
01175
01176
01177
01178
01179
01180
01181
01182
01183
01184
01185
01186
01187
01188
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199
01200
01201
01202
01203
01204
01205
01206
01207
01208
01209
01210
01211
01212
01213 typedef struct ClRefHdrI *ClRefI;
01214 typedef struct {
01215 unsigned long buflen ;
01216 struct ClRefI *prev ;
01217 CPtr Instr ;
01218 struct ClRefI *next ;
01219 } ClRefHdrI;
01220
01221
01222 #ifdef BITS64
01223 #define HIGHBIT 0x8000000000000000
01224 #else
01225 #define HIGHBIT 0x80000000
01226 #endif
01227
01228 #define PredOpCode(P) (cell_opcode(&(P)->Instr))
01229
01230 typedef ClRef SOBRef ;
01231
01232 #define ClRefAddr(Cl) ((CPtr)((ClRef)(Cl)-1))
01233 #define ClRefSize(Cl) (((ClRef)(Cl))[-1].buflen & ~0x3 & ~HIGHBIT)
01234 #define ClRefType(Cl) (((ClRef)(Cl))[-1].buflen & 0x3)
01235 #define SetClRefSize(Cl,len) (((ClRef)(Cl))[-1].buflen |= \
01236 (((ClRef)(Cl))[-1].buflen & 0x3) | ((len) & ~0x3))
01237 #define SetClRefType(Cl,type) (((ClRef)(Cl))[-1].buflen = \
01238 (((ClRef)(Cl))[-1].buflen & ~0x3) | ((type) & 0x3))
01239 #define ClRefPrev(Cl) (((ClRef)(Cl))[-1].prev)
01240 #define ClRefWord(Cl,pos) (((CPtr)(Cl))[(pos)])
01241
01242 #define SetClRefPrev(Cl,Prv) (((ClRef)(Cl))[-1].prev = (ClRef)(Prv))
01243
01244
01245
01246 #define UNINDEXED_CL 0
01247 #define SOB_RECORD 1
01248 #define TRIE_CL 2
01249 #define INDEXED_CL 3
01250
01251 #define MakeClRef(ptr,Type,NCells)\
01252 { long sz = (((NCells)*sizeof(Cell)+sizeof(ClRefHdr) + 7) & ~0x7); \
01253 (ptr) = (ClRef)mem_calloc(sz,1,ASSERT_SPACE);\
01254 (ptr)->buflen = ((Type)&3)+sz;\
01255 (ptr)++;\
01256 }
01257
01258
01259
01260 #define ClRefTryInstr(Cl) (ClRefWord((Cl),0))
01261 #define ClRefTryOpCode(Cl) (cell_opcode(&ClRefTryInstr(Cl)))
01262 #define ClRefNext(Cl) ((ClRef)ClRefWord((Cl),1))
01263
01264
01265 #define SetClRefNext(Cl,Nxt) (ClRefWord((Cl),1)=(Cell)(Nxt))
01266
01267
01268 #define ClRefEntryPoint(Cl) (&ClRefWord((Cl),2))
01269
01270
01271 #define ClRefCompiledCode(Cl) (ClRefWord((Cl),3))
01272
01273
01274
01275 #define ClRefSOBInstr(Cl) (ClRefWord((Cl),2))
01276 #define ClRefHashSize(Cl) (ClRefWord((Cl),4))
01277 #define ClRefJumpInstr(Cl) (ClRefWord((Cl),5))
01278 #define ClRefFirstIndex(Cl) (ClRefWord((Cl),6))
01279 #define ClRefLastIndex(Cl) (ClRefWord((Cl),7))
01280 #define ClRefNumNonemptyBuckets(Cl) (ClRefWord((Cl),8))
01281 #define ClRefHashTable(Cl) (&ClRefWord((Cl),9))
01282 #define ClRefHashBucket(Cl,b) ((CPtr)(ClRefHashTable(Cl)[(b)]))
01283
01284 #define ClRefSOBArg(Cl,n) (cell_operandn(&ClRefWord((Cl),2),(n)))
01285
01286
01287 #define ClRefPrRef(Cl) ((PrRef)&ClRefWord((Cl),5))
01288
01289
01290 #define PrRefClRef(Pr) ((ClRef)((CPtr)(Pr)-5))
01291
01292 #define ClRefUpSOB(Cl) (PrRefClRef(ClRefNext(Cl)))
01293
01294
01295
01296 #define ClRefNumInds(Cl)\
01297 ( (cell_operand3(&ClRefWord((Cl),2))/(sizeof(Cell)/2) + 1)/4 )
01298 #define ClRefIndPtr(Cl,Ind) (&ClRefWord((Cl),(Ind)*4))
01299
01300 #define IndPtrClRef(IP,Ind) ((ClRef)((CPtr)(IP)-(Ind)*4))
01301 #define IndRefNoop(IndPtr) ((IndPtr)[-2])
01302 #define IndRefPrev(IndPtr) (((CPtr *)(IndPtr))[-1])
01303 #define IndRefTryInstr(IndPtr) ((IndPtr)[0])
01304 #define IndRefNext(IndPtr) (((CPtr *)(IndPtr))[1])
01305
01306 #define IC_CELLS(NI) (4*(NI)+2)
01307
01308 #define ClRefIEntryPoint(Cl,NI) (&ClRefWord((Cl),IC_CELLS(NI)))
01309
01310
01311 #define ClRefEntryAny(Cl) \
01312 ((CPtr) \
01313 ((ClRefType(Cl)&1) == UNINDEXED_CL ? ClRefEntryPoint(Cl) :\
01314 ClRefIEntryPoint((Cl),ClRefNumInds(Cl)) \
01315 ))
01316
01317 #define ClRefNotRetracted(Cl) (cell_opcode(ClRefEntryAny(Cl))!=fail || \
01318 cell_operand1(ClRefEntryAny(Cl))!=MARKED_FOR_DELETION)
01319
01320 static void db_addbuff(byte, ClRef, PrRef, int, int, int);
01321 static void db_addbuff_i(byte, ClRef, PrRef, int, int *, int, prolog_term, int);
01322
01323
01324
01325
01326
01327
01328
01329
01330
01331
01332
01333
01334
01335
01336
01337
01338
01339
01340
01341
01342
01343
01344
01345
01346
01347
01348
01349
01350
01351
01352
01353
01354
01355
01356
01357
01358
01359
01360
01361
01362
01363
01364
01365
01366
01367
01368
01369
01370
01371
01372
01373
01374
01375
01376
01377
01378
01379
01380
01381
01382
01383
01384
01385
01386
01387
01388
01389
01390
01391
01392
01393
01394
01395
01396
01397
01398
01399 static void get_indexes( prolog_term prolog_ind, int *Index, int *NI )
01400 {
01401 Index[0] = 0;
01402 if (isinteger(prolog_ind)) {
01403 Index[1] = int_val(prolog_ind);
01404 if (Index[1] == 0) *NI = 0; else *NI = 1;
01405 } else {
01406 for (*NI = 0; !isnil(prolog_ind); prolog_ind = p2p_cdr(prolog_ind)) {
01407 (*NI)++;
01408 Index[*NI] = int_val(p2p_car(prolog_ind));
01409 }
01410 }
01411 }
01412
01413
01414
01415
01416 xsbBool assert_buff_to_clref_p(CTXTdeclc prolog_term,byte,PrRef,int,
01417 prolog_term,int,ClRef *);
01418
01419 xsbBool assert_buff_to_clref(CTXTdecl )
01420 {
01421 ClRef Clref;
01422 assert_buff_to_clref_p(CTXTc reg_term(CTXTc 1),
01423 (byte)ptoc_int(CTXTc 2),
01424 (PrRef)ptoc_int(CTXTc 3),
01425 ptoc_int(CTXTc 4),
01426 reg_term(CTXTc 5),
01427 ptoc_int(CTXTc 6),
01428 &Clref);
01429
01430 return TRUE;
01431 }
01432
01433 xsbBool assert_buff_to_clref_p(CTXTdeclc prolog_term Head,
01434 byte Arity,
01435 PrRef Pred,
01436 int AZ,
01437 prolog_term Indexes,
01438 int HashTabSize,
01439 ClRef *Clref)
01440 {
01441 ClRef Clause;
01442 int Location, *Loc, Inum;
01443 int Index[20], NI;
01444
01445 xsb_dbgmsg((LOG_ASSERT,"Now add clref to chain:"));
01446
01447 get_indexes( Indexes, Index, &NI ) ;
01448
01449 MakeClRef( Clause,
01450 (NI>0) ? INDEXED_CL : UNINDEXED_CL,
01451
01452 IC_CELLS(NI) + ((asrtBuff->Size+0x7)&~0x7)/sizeof(Cell) ) ;
01453
01454 if (xsb_profiling_enabled)
01455 add_prog_seg(get_str_psc(Head),(byte *)Clause,ClRefSize(Clause));
01456
01457
01458
01459
01460 Location = 0; Loc = &Location;
01461 dbgen_inst_ppv(dynnoop,sizeof(Cell)/2,Clause,Loc);
01462 write_word(Clause,Loc,0);
01463 for (Inum = NI; Inum > 0; Inum--) {
01464
01465 dbgen_inst_ppv(noop,(4*Inum-1)*sizeof(Cell)/2,Clause,Loc);
01466 write_word(Clause,Loc,0);
01467 dbgen_inst_ppv(dynnoop,sizeof(Cell)/2,Clause,Loc);
01468 write_word(Clause,Loc,0);
01469 }
01470
01471
01472
01473
01474 memmove(((pb)Clause)+Location,asrtBuff->Buff,asrtBuff->Size);
01475
01476
01477
01478 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
01479
01480 if (NI <= 0) db_addbuff(Arity,Clause,Pred,AZ,FALSE,1);
01481 else db_addbuff_i(Arity,Clause,Pred,AZ,Index,NI,Head,HashTabSize);
01482
01483 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
01484
01485 return TRUE;
01486 }
01487
01488
01489 static void prefix_to_chain(int ifSOB, byte Arity, ClRef FirstClause, ClRef NewClause)
01490 {
01491 int Loc = 0;
01492 dbgen_inst_ppvw(ifSOB?trymeelse:dyntrymeelse,Arity,FirstClause,NewClause,&Loc);
01493
01494 Loc = 0;
01495 if (ClRefTryOpCode(FirstClause) == dynnoop || ClRefTryOpCode(FirstClause) == noop)
01496 { dbgen_inst_ppvw(dyntrustmeelsefail,Arity,ClRefNext(FirstClause),
01497 FirstClause,&Loc); }
01498 else if (ClRefTryOpCode(FirstClause) == dyntrymeelse ||
01499 ClRefTryOpCode(FirstClause) == trymeelse)
01500 { dbgen_inst_ppvw(dynretrymeelse,Arity,ClRefNext(FirstClause),
01501 FirstClause,&Loc);}
01502 else xsb_dbgmsg((LOG_DEBUG,"***Error 1 in assert: 0x%x",
01503 ClRefTryOpCode(FirstClause)));
01504
01505 ClRefPrev(NewClause) = ClRefPrev(FirstClause);
01506 ClRefPrev(FirstClause) = NewClause;
01507
01508 }
01509
01510
01511 static void append_to_chain(byte Arity, ClRef LastClause, ClRef NewClause)
01512 {
01513 int Loc = 0;
01514 dbgen_inst_ppvw(dyntrustmeelsefail,Arity,ClRefNext(LastClause),
01515 NewClause,&Loc);
01516 SetClRefPrev(NewClause, LastClause);
01517
01518 Loc = 0;
01519 if (ClRefTryOpCode(LastClause) == dynnoop)
01520 { dbgen_inst_ppvw_safe(dyntrymeelse,Arity,NewClause,
01521 LastClause,&Loc); }
01522 else if (ClRefTryOpCode(LastClause) == noop)
01523 { dbgen_inst_ppvw_safe(trymeelse,Arity,NewClause,
01524 LastClause,&Loc); }
01525 else if (ClRefTryOpCode(LastClause) == dyntrustmeelsefail)
01526 { dbgen_inst_ppvw_safe(dynretrymeelse,Arity,NewClause,
01527 LastClause,&Loc); }
01528 else xsb_dbgmsg((LOG_DEBUG,"***Error 2 in assert: 0x%x",
01529 ClRefTryOpCode(LastClause)));
01530
01531 }
01532
01533
01534 static void db_addbuff(byte Arity, ClRef Clause, PrRef Pred, int AZ, int ifSOB, int Inum)
01535 {
01536 int Loc;
01537 ClRef LastClause ;
01538
01539 if (PredOpCode(Pred) == fail) {
01540 Loc = 0;
01541 dbgen_inst_ppv(ifSOB?noop:dynnoop,sizeof(Cell)/2,Clause,&Loc);
01542 SetClRefNext(Clause, Pred) ;
01543 Loc = 0;
01544 if (Inum > 1) {dbgen_inst_pppw(jump,Clause,Pred,&Loc);}
01545 else dbgen_inst_ppvw(jumptbreg,Arity,Clause,Pred,&Loc);
01546 Pred->LastClRef = Clause ;
01547 SetClRefPrev(Clause, Pred) ;
01548 } else if ( PredOpCode(Pred) == jumptbreg || PredOpCode(Pred) == jump ) {
01549 if (AZ == 0) {
01550 prefix_to_chain(ifSOB, Arity, Pred->FirstClRef, Clause);
01551 Pred->FirstClRef = Clause ;
01552 } else {
01553 LastClause = Pred->LastClRef ;
01554 append_to_chain(Arity,LastClause,Clause);
01555 Pred->LastClRef = Clause ;
01556 }
01557 } else xsb_dbgmsg((LOG_DEBUG,"***Error 3 in assert"));
01558 }
01559
01560 #define NUMHASHSIZES 16
01561
01562 static int hashsizes_table[NUMHASHSIZES] = {17,503,5003,49999,200003,400009,700001,1000003,
01563 1000033,1000037,1000039,1000081,1000099,1000117,1000121,1000133};
01564
01565 static int hash_resize( PrRef Pred, SOBRef SOBrec, unsigned int OldTabSize )
01566 {
01567 unsigned int ThisTabSize ;
01568 int i;
01569
01570
01571
01572
01573 if( PredOpCode(Pred) != fail && ClRefType(SOBrec) == SOB_RECORD ) {
01574 ThisTabSize = ClRefHashSize(SOBrec) ;
01575 if (ClRefNumNonemptyBuckets(SOBrec) > (ThisTabSize/4)*3) {
01576 if (ThisTabSize >= (unsigned int) hashsizes_table[NUMHASHSIZES-1]) {
01577 ThisTabSize = ThisTabSize+2;
01578 } else {
01579 for (i=0; i<NUMHASHSIZES; i++)
01580 if ((unsigned int) hashsizes_table[i] > ThisTabSize) break;
01581 ThisTabSize = hashsizes_table[i];
01582 }
01583
01584 }
01585 return xsb_max(ThisTabSize, OldTabSize) ;
01586 }
01587 else return OldTabSize ;
01588 }
01589
01590 static int hash_val(int Ind, prolog_term Head, int TabSize )
01591
01592 {
01593 int Hashval = 0 ;
01594 int i, j ;
01595 prolog_term Arg ;
01596
01597 if (Ind <= 0xff) {
01598 Arg = p2p_arg(Head,Ind) ;
01599
01600
01601 if (isnil(Arg)) Hashval = ihash(0, TabSize);
01602 else if (isref(Arg) || isattv(Arg)) Hashval = -1;
01603 else Hashval = ihash(val_to_hash(Arg), TabSize);
01604 } else {
01605 for (i = 2; i >= 0; i--) {
01606 j = (Ind >> (i*8)) & 0xff;
01607 if (j > 0) {
01608 if (j <= 0x80) {
01609 Arg = p2p_arg(Head,j);
01610 if (isref(Arg) || isattv(Arg)) return -1;
01611 else Hashval += Hashval + ihash(val_to_hash(Arg), TabSize);
01612 } else {
01613 prolog_term *stk[MAXTOINDEX], term;
01614 int k, depth = 0, argsleft[MAXTOINDEX];
01615 argsleft[0] = 1;
01616 term = Head; XSB_Deref(term);
01617 stk[0] = clref_val(term)+ (j - 0x80);
01618 for (k = MAXTOINDEX; k > 0; k--) {
01619
01620 if (depth < 0) break;
01621 term = *stk[depth];
01622 argsleft[depth]--;
01623 if (argsleft[depth] <= 0) depth--;
01624 else stk[depth]++;
01625 XSB_Deref(term);
01626 switch (cell_tag(term)) {
01627
01628 case XSB_FREE:
01629 case XSB_REF1:
01630 case XSB_ATTV:
01631 return -1;
01632 case XSB_INT:
01633 case XSB_FLOAT:
01634 term = (Cell)int_val(term);
01635 break;
01636 case XSB_LIST:
01637 depth++;
01638 argsleft[depth] = 2;
01639 stk[depth] = clref_val(term);
01640 term = (Cell)(list_pscPair);
01641 break;
01642 case XSB_STRUCT:
01643 if (isboxedinteger(term)) {
01644 term = (Cell)boxedint_val(term);
01645 } else if (isboxedfloat(term)) {
01646 term = int_val(cell(clref_val(term)+1)) ^
01647 int_val(cell(clref_val(term)+2)) ^
01648 int_val(cell(clref_val(term)+3));
01649 } else {
01650 depth++;
01651 argsleft[depth] = get_arity(get_str_psc(term));
01652 stk[depth] = clref_val(term)+1;
01653 term = (Cell)get_str_psc(term);
01654 }
01655 break;
01656 case XSB_STRING:
01657 term = (Cell)string_val(term);
01658 break;
01659 }
01660 Hashval += Hashval + ihash(term, TabSize);
01661 }
01662 }
01663 }
01664 }
01665 Hashval %= TabSize;
01666 }
01667 return Hashval ;
01668 }
01669
01670 static SOBRef new_SOBblock(int ThisTabSize, int Ind, Psc psc )
01671 {
01672 int i, Loc ;
01673 SOBRef NewSOB ;
01674
01675
01676 MakeClRef(NewSOB,SOB_RECORD,9+ThisTabSize);
01677
01678
01679 if (xsb_profiling_enabled)
01680 add_prog_seg(psc,(byte *)NewSOB,ClRefSize(NewSOB));
01681
01682 Loc = 0 ;
01683 dbgen_inst3_sob( Ind>0xff ? switchon3bound : switchonbound,
01684 Ind,((Integer)ClRefHashTable(NewSOB)),ThisTabSize,&ClRefSOBInstr(NewSOB),&Loc);
01685
01686 Loc = 0 ;
01687 dbgen_inst_ppp(fail,&ClRefJumpInstr(NewSOB),&Loc);
01688 ClRefFirstIndex(NewSOB) = (Cell)&ClRefJumpInstr(NewSOB) ;
01689 ClRefLastIndex( NewSOB) = (Cell)&ClRefJumpInstr(NewSOB) ;
01690 ClRefNumNonemptyBuckets(NewSOB) = 0 ;
01691
01692
01693 for (i = 0; i < ThisTabSize; i++)
01694 ClRefHashTable(NewSOB)[i] = (Cell)&dynfail_inst ;
01695
01696 return NewSOB ;
01697 }
01698
01699 static void addto_hashchain( int AZ, int Hashval, SOBRef SOBrec, CPtr NewInd,
01700 int Arity )
01701 {
01702 CPtr *Bucketaddr = (CPtr *) (ClRefHashTable(SOBrec) + Hashval);
01703 CPtr OldInd = *Bucketaddr ;
01704 int Loc ;
01705
01706 if ((pb)OldInd == (pb)&dynfail_inst) {
01707 *Bucketaddr = NewInd ;
01708 IndRefPrev(NewInd) = (CPtr) Bucketaddr ;
01709 IndRefNext(NewInd) = (CPtr) SOBrec ;
01710 ClRefNumNonemptyBuckets(SOBrec)++ ;
01711 } else if (AZ == 0) {
01712 Loc = 0;
01713 dbgen_inst_ppvw(dyntrymeelse,Arity,OldInd,NewInd,&Loc);
01714 Loc = 0;
01715 if (cell_opcode(OldInd) == dynnoop)
01716 { dbgen_inst_ppvw(dyntrustmeelsefail,Arity,IndRefNext(OldInd),
01717 OldInd,&Loc); }
01718 else
01719 { dbgen_inst_ppvw(dynretrymeelse,Arity,IndRefNext(OldInd),
01720 OldInd,&Loc); }
01721 IndRefPrev(OldInd) = NewInd;
01722 *Bucketaddr = NewInd ;
01723 IndRefPrev(NewInd) = (CPtr) Bucketaddr ;
01724 } else {
01725 Loc = 0;
01726 dbgen_inst_ppvw(dyntrustmeelsefail,Arity, SOBrec, NewInd,&Loc);
01727 Loc = 0;
01728 if (cell_opcode(OldInd) == dynnoop)
01729 { dbgen_inst_ppvw_safe(dyntrymeelse,Arity,NewInd,OldInd,&Loc); }
01730 else {
01731 while (cell_opcode(OldInd) != dyntrustmeelsefail)
01732 OldInd = IndRefNext(OldInd);
01733 dbgen_inst_ppvw_safe(dynretrymeelse,Arity,NewInd,OldInd,&Loc);
01734 }
01735 IndRefPrev(NewInd) = OldInd ;
01736 }
01737 }
01738
01739 static void addto_allchain( int AZ, ClRef Clause, SOBRef SOBrec, byte Arity)
01740 {
01741 ClRef Last, First ;
01742 int Loc ;
01743
01744
01745 if (PredOpCode(ClRefPrRef(SOBrec)) == fail) {
01746 Loc = 0;
01747 dbgen_inst_ppv(dynnoop,sizeof(Cell)/2,Clause,&Loc);
01748 Loc = 0 ;
01749 dbgen_inst_pppw(jump,Clause,ClRefPrRef(SOBrec),&Loc);
01750 ClRefLastIndex(SOBrec) = (Cell) Clause ;
01751 ClRefPrev(Clause) = SOBrec ;
01752 SetClRefNext(Clause, SOBrec);
01753 } else if (AZ == 0) {
01754 First = (ClRef) ClRefFirstIndex(SOBrec);
01755 prefix_to_chain(FALSE,Arity,First,Clause);
01756 ClRefPrev(First) = Clause;
01757 ClRefFirstIndex(SOBrec) = (Cell) Clause;
01758 } else {
01759 Last = (ClRef) ClRefLastIndex(SOBrec);
01760 append_to_chain(Arity, Last, Clause);
01761 ClRefPrev(Clause) = Last ;
01762 ClRefLastIndex(SOBrec) = (Cell) Clause;
01763 }
01764 }
01765
01766
01767 static void db_addbuff_i(byte Arity, ClRef Clause, PrRef Pred, int AZ,
01768 int *Index, int NI, prolog_term Head, int HashTabSize)
01769 { SOBRef SOBbuff ;
01770 int Inum, Ind;
01771 unsigned int ThisTabSize; int Hashval;
01772
01773 SOBbuff = AZ == 0 ? Pred->FirstClRef : Pred->LastClRef ;
01774 HashTabSize = ThisTabSize = hash_resize(Pred, SOBbuff, HashTabSize);
01775
01776 for (Inum = 1; Inum <= NI; Inum++) {
01777 SOBbuff = AZ == 0 ? Pred->FirstClRef : Pred->LastClRef ;
01778 Ind = Index[Inum];
01779 Hashval = hash_val(Ind, Head, ThisTabSize) ;
01780 if (Hashval < 0) {Hashval = 0; ThisTabSize = 1;}
01781 if (PredOpCode(Pred) == fail || ClRefType(SOBbuff) != SOB_RECORD
01782 || ClRefHashSize(SOBbuff) != ThisTabSize
01783 || ClRefSOBArg(SOBbuff,1) != (byte)(Ind>>16)
01784 || ClRefSOBArg(SOBbuff,2) != (byte)(Ind>>8)
01785 || ClRefSOBArg(SOBbuff,3) != (byte)Ind) {
01786 SOBbuff = new_SOBblock(ThisTabSize,Ind,get_str_psc(Head));
01787
01788 db_addbuff(Arity,SOBbuff,Pred,AZ,TRUE,Inum);
01789 }
01790 Pred = ClRefPrRef(SOBbuff) ;
01791 addto_hashchain(AZ, Hashval, SOBbuff, ClRefIndPtr(Clause,Inum), Arity);
01792 }
01793 addto_allchain( AZ, Clause, SOBbuff, Arity ) ;
01794 }
01795
01800 static void find_usable_index(prolog_term Head, ClRef *s,
01801 int *ILevel, int *Index ) {
01802 int i,Ind = 0;
01803
01804 *Index = *ILevel = 0 ;
01805 for (i = 1; ClRefType(*s) == SOB_RECORD; i++ ) {
01806 if (Head != (prolog_term)NULL) {
01807 Ind = ((ClRefSOBArg(*s,1) << 8) | ClRefSOBArg(*s,2) ) << 8 |
01808 ClRefSOBArg(*s,3) ;
01809 if (hash_val(Ind,Head,1) >= 0) {
01810 *Index = Ind; *ILevel = i;
01811 break ;
01812 }
01813 }
01814 *s = (ClRef)ClRefFirstIndex(*s);
01815 }
01816
01817 }
01818
01819
01820
01821
01822
01823
01824
01825
01826 #define CheckSOBClause(H, Ind, sob, Level ) \
01827 { int h, t ; \
01828 ClRef cl ; \
01829 t = ClRefHashSize(sob); \
01830 h = hash_val( (Ind), (H), t ) ; \
01831 cl = (ClRef) ClRefHashTable(sob)[h] ; \
01832 if ((pb)cl != (pb)&dynfail_inst) \
01833 return IndPtrClRef(cl,Level) ; \
01834 }
01835
01836
01837
01838
01839
01840
01841
01842
01843 #define NextSOB(sob,curLevel,IndLevel,Ind,Head) \
01844 { while( ClRefTryOpCode(sob) == dyntrustmeelsefail \
01845 || ClRefTryOpCode(sob) == noop ) \
01846 if( curLevel-- == 1 ) \
01847 return 0 ; \
01848 else sob = ClRefUpSOB(sob) ; \
01849 sob = ClRefNext(sob) ; \
01850 if (curLevel == 1) { \
01851 find_usable_index(Head,&sob,IndLevel,Ind); \
01852 curLevel = *IndLevel; \
01853 } \
01854 if( ClRefType(sob) != SOB_RECORD ) return sob; \
01855 }
01856
01857
01858
01859
01860
01861 #define FirstClauseSOB(sob,curLevel,IndLevel,Head,Ind) \
01862 { for(;;) \
01863 if( curLevel < *IndLevel ) \
01864 { sob = ClRefPrRef(sob)->FirstClRef; \
01865 curLevel++ ; \
01866 } \
01867 else \
01868 { CheckSOBClause(Head,*Ind,sob,curLevel) ; \
01869 NextSOB(sob,curLevel,IndLevel,Ind,Head) ; \
01870 } \
01871 }
01872
01873 ClRef first_clref( PrRef Pred, prolog_term Head, int *ILevel, int *Index )
01874 { SOBRef sob ;
01875 int curLevel ;
01876
01877 if( PredOpCode(Pred) == fail )
01878 return 0 ;
01879
01880
01881 sob = Pred->FirstClRef;
01882 find_usable_index(Head,&sob,ILevel,Index);
01883
01884 if( *ILevel == 0 )
01885 return sob ;
01886 else
01887 { curLevel = *ILevel ;
01888 FirstClauseSOB(sob,curLevel,ILevel,Head,Index) ;
01889 }
01890 }
01891
01892 ClRef next_clref( PrRef Pred, ClRef Clause, prolog_term Head,
01893 int *IndexLevel, int *Ind )
01894 { SOBRef sob ;
01895 int numInds ;
01896 int curLevel ;
01897 CPtr PI ;
01898
01899 if( ClRefType(Clause) != INDEXED_CL ) {
01900 if( ClRefTryOpCode(Clause) == dyntrustmeelsefail
01901 || ClRefTryOpCode(Clause) == dynnoop
01902 || ClRefTryOpCode(Clause) == noop)
01903 return 0 ;
01904 else if( ClRefType(ClRefNext(Clause)) != SOB_RECORD )
01905 return ClRefNext(Clause) ;
01906 else
01907 { sob = ClRefNext(Clause) ;
01908 if( *IndexLevel == 0 )
01909 { while( ClRefType(sob) == SOB_RECORD )
01910 sob = ClRefPrRef(sob)->FirstClRef ;
01911 return sob ;
01912 }
01913 else
01914 { for( curLevel = 1 ; curLevel < *IndexLevel ; curLevel++ )
01915 sob = ClRefPrRef(sob)->FirstClRef ;
01916 CheckSOBClause(Head,*Ind,sob,*IndexLevel) ;
01917 NextSOB(sob,curLevel,IndexLevel,Ind,Head) ;
01918 FirstClauseSOB(sob,curLevel,IndexLevel,Head,Ind) ;
01919 }
01920 }
01921 }
01922 else if( *IndexLevel == 0 ) {
01923 if( ClRefTryOpCode(Clause) == dyntrymeelse ||
01924 ClRefTryOpCode(Clause) == dynretrymeelse )
01925 return ClRefNext(Clause) ;
01926 else
01927 { numInds = curLevel = ClRefNumInds(Clause);
01928
01929 sob = ClRefNext(Clause);
01930 NextSOB(sob,curLevel,IndexLevel,Ind,Head);
01931
01932 while( curLevel++ < numInds ) {
01933 sob = ClRefPrRef(sob)->FirstClRef ;
01934 }
01935 return ClRefPrRef(sob)->FirstClRef ;
01936 }
01937 }
01938 else
01939 { PI = ClRefIndPtr(Clause,*IndexLevel) ;
01940 if( cell_opcode(PI) == dyntrymeelse ||
01941 cell_opcode(PI) == dynretrymeelse )
01942 return IndPtrClRef(IndRefNext(PI),*IndexLevel) ;
01943 else
01944 {
01945 sob = (SOBRef)IndRefNext(PI) ;
01946 curLevel = *IndexLevel ;
01947 NextSOB(sob,curLevel,IndexLevel,Ind,Head) ;
01948 FirstClauseSOB(sob,curLevel,IndexLevel,Head,Ind) ;
01949 }
01950 }
01951 }
01952
01953
01954
01955
01956
01957
01958
01959
01960
01961
01962 #define delete_from_chain( c, PC, Displ ) \
01963 { switch( c ) \
01964 { case noop: \
01965 case dynnoop: \
01966 break ; \
01967 case trymeelse: \
01968 IndRefPrev(IndRefNext(PC)) = IndRefPrev(PC) ; \
01969 if( cell_opcode(IndRefNext(PC)) == dynretrymeelse ) \
01970 cell_opcode(IndRefNext(PC)) = trymeelse ; \
01971 else \
01972 { cell_opcode(IndRefNext(PC)) = noop ; \
01973 cell_operand3(IndRefNext(PC)) = (Displ) ; \
01974 } \
01975 break ; \
01976 case dyntrymeelse: \
01977 IndRefPrev(IndRefNext(PC)) = IndRefPrev(PC) ; \
01978 if( cell_opcode(IndRefNext(PC)) == dynretrymeelse ) \
01979 cell_opcode(IndRefNext(PC)) = dyntrymeelse ; \
01980 else \
01981 { cell_opcode(IndRefNext(PC)) = dynnoop ; \
01982 cell_operand3(IndRefNext(PC)) = (Displ) ; \
01983 } \
01984 break ; \
01985 case dynretrymeelse: \
01986 IndRefPrev(IndRefNext(PC)) = IndRefPrev(PC) ; \
01987 IndRefNext(IndRefPrev(PC)) = IndRefNext(PC) ; \
01988 break ; \
01989 case dyntrustmeelsefail: \
01990 IndRefNext(IndRefPrev(PC)) = IndRefNext(PC) ; \
01991 if( cell_opcode(IndRefPrev(PC)) == dynretrymeelse ) \
01992 cell_opcode(IndRefPrev(PC)) = dyntrustmeelsefail ; \
01993 else if (cell_opcode(IndRefPrev(PC)) == trymeelse ) \
01994 { cell_opcode(IndRefPrev(PC)) = noop ; \
01995 cell_operand3(IndRefPrev(PC)) = (Displ) ; \
01996 } \
01997 else \
01998 { cell_opcode(IndRefPrev(PC)) = dynnoop ; \
01999 cell_operand3(IndRefPrev(PC)) = (Displ) ; \
02000 } \
02001 break ; \
02002 default: \
02003 xsb_exit("error removing a clause: %x",c) ; \
02004 break ; \
02005 } \
02006 }
02007
02008
02009
02010 static void delete_from_hashchain( ClRef Clause, int Ind, int NI )
02011 {
02012 CPtr PI = ClRefIndPtr(Clause,Ind) ;
02013 byte c = cell_opcode(PI) ;
02014
02015 delete_from_chain(c,PI,((NI-Ind)*4+1)*sizeof(Cell)/2) ;
02016
02017 if( cell_opcode(PI) == dynnoop) {
02018 *IndRefPrev(PI) = (Cell) &dynfail_inst ;
02019 }
02022 else if( cell_opcode(PI) == dyntrymeelse )
02023 *IndRefPrev(PI) = (Cell) IndRefNext(PI) ;
02024 }
02025
02026
02027
02028 static void delete_from_allchain( ClRef Clause )
02029 {
02030 PrRef Pred ;
02031 byte c = ClRefTryOpCode(Clause) ;
02032
02033 delete_from_chain( c, (CPtr)Clause, sizeof(Cell)/2 ) ;
02034
02035 switch( c )
02036 { case dynnoop:
02037 Pred = ClRefPrRef(ClRefPrev(Clause)) ;
02038 PredOpCode(Pred) = fail ;
02039 Pred->FirstClRef = Pred->LastClRef = (ClRef) Pred ;
02040 break ;
02041 case dyntrymeelse:
02042 case trymeelse:
02043 Pred = ClRefPrRef(ClRefPrev(Clause)) ;
02044 Pred->FirstClRef = ClRefNext(Clause) ;
02045 break ;
02046 case dyntrustmeelsefail:
02047 Pred = ClRefPrRef(ClRefNext(Clause)) ;
02048 Pred->LastClRef = ClRefPrev(Clause) ;
02049 break ;
02050 }
02051 }
02052
02053
02054
02055
02056
02057 static void delete_from_sobchain(ClRef Clause)
02058 {
02059 PrRef Pred ;
02060 byte c = ClRefTryOpCode(Clause) ;
02061
02062 delete_from_chain( c, (CPtr)Clause, sizeof(Cell)/2 ) ;
02063
02064 switch( c )
02065 { case dynnoop:
02066 Pred = (PrRef)ClRefPrev(Clause) ;
02067 PredOpCode(Pred) = fail ;
02068 Pred->FirstClRef = Pred->LastClRef = (ClRef) Pred ;
02069 break ;
02070 case noop:
02071 Pred = (PrRef)ClRefPrev(Clause) ;
02072 PredOpCode(Pred) = fail ;
02073 Pred->FirstClRef = Pred->LastClRef = (ClRef) Pred ;
02074 break ;
02075 case dyntrymeelse:
02076 case trymeelse:
02077 Pred = (PrRef)ClRefPrev(Clause) ;
02078 Pred->FirstClRef = ClRefNext(Clause) ;
02079 break ;
02080 case dyntrustmeelsefail:
02081 Pred = (PrRef)ClRefNext(Clause) ;
02082 Pred->LastClRef = ClRefPrev(Clause) ;
02083 break ;
02084 }
02085 }
02086
02087
02088
02089
02090
02091
02092
02093
02094
02095
02096
02097
02098
02099
02100
02101
02102
02103
02104
02105
02106
02107
02108
02109
02110
02111
02112
02113
02114
02115
02116
02117
02118 #define is_dynamic_clause_inst(inst) \
02119 ((int) inst == dynretrymeelse || (int) inst == dyntrustmeelsefail)
02120
02121
02122
02123
02124
02125
02126 #define mark_clref(pClRef) \
02127 (ClRef_Buflen(pClRef -1) = ClRef_Buflen(pClRef - 1) | HIGHBIT)
02128
02129 #define unmark_clref(pClRef) \
02130 (ClRef_Buflen(pClRef -1) = ClRef_Buflen(pClRef - 1 ) & (~HIGHBIT))
02131
02132 #define clref_is_marked(pClRef) \
02133 (ClRef_Buflen(pClRef -1 ) & HIGHBIT)
02134
02135
02136
02137 ClRef clref_from_try_addr(ClRef code_addr) {
02138 while (cell_opcode((CPtr)code_addr - 2) == noop) {
02139 code_addr = (ClRef)((CPtr)code_addr - 4);
02140 }
02141 return (ClRef)code_addr;
02142 }
02143
02144
02145
02146
02147
02148
02149
02150 int mark_cpstack_retract(CTXTdeclc ClRef clref) {
02151 CPtr cp_top,cp_bot, cp_inst_addr ;
02152 byte cp_inst;
02153 int found_match;
02154 ClRef cp_clref;
02155
02156 cp_bot = (CPtr)(tcpstack.high) - CP_SIZE;
02157
02158 cp_top = ((bfreg < breg)? bfreg : breg) ;
02159 found_match = 0;
02160 while ( cp_top < cp_bot && !(found_match)) {
02161 cp_inst = *(byte *)*cp_top;
02162 if ( is_dynamic_clause_inst(cp_inst) ) {
02163 cp_clref = clref_from_try_addr((ClRef)*cp_top);
02164 if (clref == cp_clref) {
02165
02166 found_match = 1;
02167 }
02168 else {
02169 mark_clref(cp_clref);
02170 }
02171 }
02172 else {
02173 cp_inst_addr = (CPtr) *cp_top;
02174 if (cp_inst_addr == dbclause_cgc_block_gl
02175 || (cp_inst_addr > standard_cgc_block_begin_gl
02176 && cp_inst_addr < standard_cgc_block_end_gl)) {
02177
02178 found_match = 1;
02179 }
02180 }
02181 cp_top = cp_prevtop(cp_top);
02182 }
02183 return found_match;
02184 }
02185
02186
02187
02188 void unmark_cpstack_retract(CTXTdecl) {
02189 CPtr cp_top,cp_bot ;
02190 byte cp_inst;
02191 ClRef cp_clref;
02192
02193 cp_bot = (CPtr)(tcpstack.high) - CP_SIZE;
02194
02195 cp_top = ((bfreg < breg)? bfreg : breg) ;
02196 while ( cp_top < cp_bot ) {
02197 cp_inst = *(byte *)*cp_top;
02198 if ( is_dynamic_clause_inst(cp_inst) ) {
02199 cp_clref = clref_from_try_addr((ClRef)*cp_top);
02200 unmark_clref(cp_clref);
02201 }
02202 cp_top = cp_prevtop(cp_top);
02203 }
02204 }
02205
02206
02207
02208
02209
02210
02211
02212
02213
02214
02215 int mark_cpstack_retractall(CTXTdecl) {
02216 CPtr cp_top,cp_bot,cp_inst_addr ;
02217 byte cp_inst;
02218 ClRef cp_clref;
02219 int found_match = 0;
02220
02221 cp_bot = (CPtr)(tcpstack.high) - CP_SIZE;
02222
02223 cp_top = ((bfreg < breg)? bfreg : breg) ;
02224 while ( cp_top < cp_bot && !found_match) {
02225 cp_inst = *(byte *)*cp_top;
02226 if ( is_dynamic_clause_inst(cp_inst) ) {
02227 cp_clref = clref_from_try_addr((ClRef)*cp_top);
02228 mark_clref(cp_clref);
02229 }
02230 else {
02231 cp_inst_addr = (CPtr) *cp_top;
02232 if (cp_inst_addr == dbclause_cgc_block_gl
02233 || (cp_inst_addr > standard_cgc_block_begin_gl
02234 && cp_inst_addr < standard_cgc_block_end_gl)) {
02235
02236 found_match = 1;
02237 }
02238 }
02239 cp_top = cp_prevtop(cp_top);
02240 }
02241 return found_match;
02242 }
02243
02244
02245
02246 static inline int dyntabled_incomplete(CTXTdeclc Psc psc) {
02247 if (get_tabled(psc) && !is_completed_table(get_tip(CTXTc psc)))
02248 return TRUE;
02249 else return FALSE;
02250 }
02251
02252
02253
02254
02255
02256
02257
02258
02259
02260
02261 int check_cpstack_retractall(CTXTdeclc PrRef prref) {
02262
02263 CPtr cp_top,cp_bot, cp_inst_addr;
02264 byte cp_inst;
02265 int found_prref_match;
02266 ClRef clref_ptr;
02267
02268 cp_bot = (CPtr)(tcpstack.high) - CP_SIZE;
02269
02270 cp_top = ((bfreg < breg)? bfreg : breg) ;
02271 found_prref_match = 0;
02272 while ( cp_top < cp_bot && !(found_prref_match)) {
02273 cp_inst = *(byte *)*cp_top;
02274
02275 if ( is_dynamic_clause_inst(cp_inst) ) {
02276 clref_ptr = clref_from_try_addr((ClRef)*cp_top);
02277 if (prref == clref_to_prref(clref_ptr)) {
02278 found_prref_match = 1;
02279 }
02280 }
02281 else {
02282 cp_inst_addr = (CPtr) *cp_top;
02283 if (cp_inst_addr == dbclause_cgc_block_gl
02284 || (cp_inst_addr > standard_cgc_block_begin_gl
02285 && cp_inst_addr < standard_cgc_block_end_gl)) {
02286
02287 found_prref_match = 1;
02288 }
02289 }
02290 cp_top = cp_prevtop(cp_top);
02291 }
02292 return found_prref_match;
02293 }
02294
02295
02296
02297
02298
02299
02300
02301
02302
02303
02304
02305
02306
02307
02308
02309
02310
02311
02312 DelCFptr delcf_chain_begin = (DelCFptr) NULL;
02313
02314
02315
02316
02317 DelCFptr new_DelCF_pred(CTXTdeclc PrRef pPrRef,Psc pPSC,
02318 DelCFptr *chain_begin) {
02319 DelCFptr pDCF;
02320
02321 pDCF = (DelCFptr)mem_alloc(sizeof(DeletedClauseFrame),ASSERT_SPACE);
02322 if ( IsNULL(pDCF) )
02323 xsb_abort("Ran out of memory in allocation of DeletedClauseFrame");
02324 DCF_PrRef(pDCF) = pPrRef;
02325 DCF_ClRef(pDCF) = PrRef_FirstClRef(pPrRef);
02326 DCF_PSC(pDCF) = pPSC;
02327 DCF_Type(pDCF) = DELETED_PRREF;
02328 DCF_Mark(pDCF) = 0;
02329 DCF_PrevDCF(pDCF) = 0;
02330 DCF_PrevPredDCF(pDCF) = 0;
02331 DCF_NextDCF(pDCF) = *chain_begin;
02332 DCF_NextPredDCF(pDCF) = PrRef_DelCF(pPrRef);
02333 if (*chain_begin) DCF_PrevDCF(*chain_begin) = pDCF;
02334 if (PrRef_DelCF(pPrRef)) DCF_PrevPredDCF(PrRef_DelCF(pPrRef)) = pDCF;
02335 *chain_begin = pDCF;
02336 PrRef_DelCF(pPrRef) = pDCF;
02337 return pDCF;
02338 }
02339
02340
02341
02342
02343
02344
02345 DelCFptr new_DelCF_clause(PrRef pPrRef,Psc pPSC,ClRef pClRef,
02346 DelCFptr *chain_begin) {
02347 DelCFptr pDCF;
02348
02349 pDCF = (DelCFptr)mem_alloc(sizeof(DeletedClauseFrame),ASSERT_SPACE);
02350 if ( IsNULL(pDCF) )
02351 xsb_abort("Ran out of memory in allocation of DeletedClauseFrame");
02352 DCF_PrRef(pDCF) = pPrRef;
02353 DCF_ClRef(pDCF) = pClRef;
02354 DCF_PSC(pDCF) = pPSC;
02355 DCF_Type(pDCF) = DELETED_CLREF;
02356 DCF_Mark(pDCF) = 0;
02357 DCF_PrevDCF(pDCF) = 0;
02358 DCF_PrevPredDCF(pDCF) = 0;
02359 DCF_NextDCF(pDCF) = *chain_begin;
02360 DCF_NextPredDCF(pDCF) = PrRef_DelCF(pPrRef);
02361 if (*chain_begin) DCF_PrevDCF(*chain_begin) = pDCF;
02362 if (PrRef_DelCF(pPrRef)) DCF_PrevPredDCF(PrRef_DelCF(pPrRef)) = pDCF;
02363 *chain_begin = pDCF;
02364 PrRef_DelCF(pPrRef) = pDCF;
02365 return pDCF;
02366 }
02367
02368
02369
02370
02371
02372
02373
02374 #define Free_DelCF(pDCF,pPRREF,chain_begin) { \
02375 if (DCF_PrevDCF(pDCF) == 0) { \
02376 chain_begin = DCF_NextDCF(pDCF); \
02377 } \
02378 else { \
02379 DCF_NextDCF(DCF_PrevDCF(pDCF)) = DCF_NextDCF(pDCF); \
02380 } \
02381 if (DCF_NextDCF(pDCF) != 0) { \
02382 DCF_PrevDCF(DCF_NextDCF(pDCF)) = DCF_PrevDCF(pDCF); \
02383 } \
02384 if (DCF_PrevPredDCF(pDCF) == 0 && pPRREF) { \
02385 PrRef_DelCF(pPRREF) = DCF_NextPredDCF(pDCF); \
02386 } \
02387 else { \
02388 DCF_NextPredDCF(DCF_PrevPredDCF(pDCF)) = DCF_NextPredDCF(pDCF); \
02389 } \
02390 if (DCF_NextPredDCF(pDCF) != 0) { \
02391 DCF_PrevPredDCF(DCF_NextPredDCF(pDCF)) = DCF_PrevPredDCF(pDCF); \
02392 } \
02393 mem_dealloc(pDCF,sizeof(DeletedTableFrame),ASSERT_SPACE); \
02394 }
02395
02396
02397
02398
02399
02400
02401
02402
02403
02404
02405
02406
02407
02408
02409 void check_insert_global_delcf_pred(CTXTdeclc PrRef prref,Psc psc) {
02410 DelCFptr dcf = PrRef_DelCF(prref);
02411
02412 SYS_MUTEX_LOCK(MUTEX_DYNAMIC);
02413 while ( dcf != 0 ) {
02414 if (DCF_Type(dcf) == DELETED_CLREF) {
02415
02416
02417 Free_DelCF(dcf,prref,delcf_chain_begin);
02418 }
02419 dcf = DCF_NextPredDCF(dcf);
02420 }
02421 dcf = new_DelCF_pred(CTXTc prref,psc,&delcf_chain_begin);
02422 SYS_MUTEX_UNLOCK(MUTEX_DYNAMIC);
02423 }
02424
02425 #ifdef MULTI_THREAD
02426 void check_insert_private_delcf_pred(CTXTdeclc PrRef prref,Psc psc) {
02427 DelCFptr dcf = PrRef_DelCF(prref);
02428
02429 while ( dcf != 0 ) {
02430 if (DCF_Type(dcf) == DELETED_CLREF) {
02431
02432
02433 Free_DelCF(dcf,prref,private_delcf_chain_begin);
02434 }
02435 dcf = DCF_NextPredDCF(dcf);
02436 }
02437 dcf = new_DelCF_pred(CTXTc prref,psc,&private_delcf_chain_begin);
02438 }
02439 #endif
02440
02441
02442
02443
02444 void check_insert_global_delcf_clause(CTXTdeclc PrRef prref,
02445 Psc psc,ClRef clref) {
02446 DelCFptr dcf = PrRef_DelCF(prref);
02447 int found = 0;
02448
02449 SYS_MUTEX_LOCK(MUTEX_DYNAMIC);
02450
02451
02452
02453
02454
02455
02456
02457
02458 if (!found) {
02459 dcf = new_DelCF_clause(prref,psc,clref,&delcf_chain_begin);
02460 }
02461 SYS_MUTEX_UNLOCK(MUTEX_DYNAMIC);
02462 }
02463
02464 #ifdef MULTI_THREAD
02465 void check_insert_private_delcf_clause(CTXTdeclc PrRef prref,
02466 Psc psc,ClRef clref) {
02467 DelCFptr dcf = PrRef_DelCF(prref);
02468 int found = 0;
02469
02470
02471
02472
02473
02474
02475
02476
02477
02478 if (!found) {
02479 dcf = new_DelCF_clause(prref,psc,clref,&private_delcf_chain_begin);
02480 }
02481 }
02482
02483 #define check_insert_shared_delcf_pred(context,prref,psc) \
02484 check_insert_global_delcf_pred(context,prref,psc)
02485
02486 #define check_insert_shared_delcf_clause(context,prref,psc,clref) \
02487 check_insert_global_delcf_clause(context,prref,psc,clref)
02488
02489 #define check_insert_private_delcf_pred(context,prref,psc) \
02490 check_insert_private_delcf_pred(context,prref,psc)
02491
02492 #define check_insert_private_delcf_clause(context,prref,psc,clref) \
02493 check_insert_global_delcf_clause(context,prref,psc,clref)
02494
02495 #else
02496 #define check_insert_private_delcf_pred(prref,psc) \
02497 check_insert_global_delcf_pred(prref,psc)
02498
02499 #define check_insert_private_delcf_clause(prref,psc,clref) \
02500 check_insert_global_delcf_clause(prref,psc,clref)
02501 #endif
02502
02503
02504
02505
02506
02507
02508
02509
02510
02511
02512
02513
02514
02515
02516
02517
02518
02519
02520
02521
02522
02523 void mark_delcf_subchain(CTXTdeclc DelCFptr delcf,ClRef clref) {
02524 PrRef prref;
02525
02526 prref = clref_to_prref(clref);
02527 while (delcf) {
02528 if (dyntabled_incomplete(CTXTc DCF_PSC(delcf))) {
02529 DCF_Mark(delcf) = 1;
02530
02531
02532 }
02533 if (DCF_Type(delcf) == DELETED_PRREF && prref == DCF_PrRef(delcf) ) {
02534 DCF_Mark(delcf) = 1;
02535
02536
02537 } else if (DCF_Type(delcf) == DELETED_CLREF && DCF_ClRef(delcf) == clref) {
02538 DCF_Mark(delcf) = 1;
02539
02540
02541 }
02542 delcf = DCF_NextPredDCF(delcf);
02543 }
02544 }
02545
02546
02547
02548
02549
02550
02551
02552
02553
02554
02555
02556
02557 int mark_dynamic(CTXTdecl)
02558 {
02559 CPtr cp_top,cp_bot, cp_inst_addr ;
02560 byte cp_inst;
02561 ClRef clref_ptr;
02562 PrRef prref_ptr;
02563 int found_match = 0;
02564
02565 cp_bot = (CPtr)(tcpstack.high) - CP_SIZE;
02566 cp_top = ((bfreg < breg)? bfreg : breg) ;
02567
02568 while ( cp_top < cp_bot && !found_match) {
02569 cp_inst = *(byte *)*cp_top;
02570 if ( is_dynamic_clause_inst(cp_inst) ) {
02571 clref_ptr = clref_from_try_addr((ClRef)*cp_top);
02572 mark_clref(clref_ptr);
02573 prref_ptr = clref_to_prref(clref_ptr);
02574 mark_delcf_subchain(CTXTc PrRef_DelCF(prref_ptr),clref_ptr);
02575 }
02576 else {
02577 cp_inst_addr = (CPtr) *cp_top;
02578 if (cp_inst_addr == dbclause_cgc_block_gl
02579 || (cp_inst_addr > standard_cgc_block_begin_gl
02580 && cp_inst_addr < standard_cgc_block_end_gl)) {
02581
02582 found_match = 1;
02583 }
02584 }
02585 cp_top = cp_prevtop(cp_top);
02586 }
02587 return found_match;
02588 }
02589
02590 void gc_retractall(CTXTdeclc ClRef);
02591 int determine_if_safe_to_delete(ClRef);
02592 static int really_delete_clause(ClRef);
02593
02594
02595
02596
02597
02598
02599
02600 int sweep_dynamic(CTXTdeclc DelCFptr *chain_begin) {
02601 DelCFptr next_delcf_ptr, delcf_ptr = *chain_begin;
02602 int dcf_cnt = 0;
02603 PrRef prref;
02604
02605
02606 while (delcf_ptr) {
02607 next_delcf_ptr = DCF_NextDCF(delcf_ptr);
02608 if (DCF_Mark(delcf_ptr)) {
02609
02610
02611 DCF_Mark(delcf_ptr) = 0;
02612 dcf_cnt++;
02613 }
02614 else {
02615 if (DCF_Type(delcf_ptr) == DELETED_PRREF) {
02616
02617
02618 gc_retractall(CTXTc DCF_ClRef(delcf_ptr));
02619 prref = dynpredep_to_prref(CTXTc get_ep(DCF_PSC(delcf_ptr)));
02620 Free_DelCF(delcf_ptr,prref,*chain_begin);
02621 }
02622 else {
02623 if (DTF_Type(delcf_ptr) == DELETED_CLREF) {
02624 if (determine_if_safe_to_delete(DCF_ClRef(delcf_ptr))) {
02625
02626
02627
02628 really_delete_clause(DCF_ClRef(delcf_ptr));
02629 prref = dynpredep_to_prref(CTXTc get_ep(DCF_PSC(delcf_ptr)));
02630 Free_DelCF(delcf_ptr,prref,*chain_begin);
02631 } else {
02632 dcf_cnt++;
02633
02634
02635 }
02636 }
02637 }
02638 }
02639 delcf_ptr = next_delcf_ptr;
02640 }
02641 return dcf_cnt;
02642 }
02643
02644
02645
02646
02647
02648
02649
02650 int gc_dynamic(CTXTdecl)
02651 {
02652 int ctr = -1;
02653
02654 if (pflags[CLAUSE_GARBAGE_COLLECT] == 0) return -1;
02655
02656 #ifdef MULTI_THREAD
02657 if (flags[NUM_THREADS] == 1 ) {
02658 if (!delcf_chain_begin && !private_delcf_chain_begin) return 0;
02659 if (!mark_dynamic(CTXT)) {
02660 ctr = sweep_dynamic(CTXTc &delcf_chain_begin) +
02661 sweep_dynamic(CTXTc &private_delcf_chain_begin);
02662 }
02663 unmark_cpstack_retract(CTXT);
02664 } else {
02665 if (!private_delcf_chain_begin) return 0;
02666 if (!mark_dynamic(CTXT)) {
02667 ctr = sweep_dynamic(CTXTc &private_delcf_chain_begin);
02668 }
02669 unmark_cpstack_retract(CTXT);
02670 }
02671 #else
02672 if (!delcf_chain_begin) return 0;
02673 if (!mark_dynamic(CTXT)) {
02674 ctr = sweep_dynamic(CTXTc &delcf_chain_begin);
02675 }
02676 unmark_cpstack_retract(CTXT);
02677 #endif
02678 return ctr;
02679 }
02680
02681 #define FIXED_BLOCK_SIZE_FOR_TABLED_PRED (8 * sizeof(Cell))
02682
02683
02684
02685
02686 #ifdef MULTI_THREAD
02687
02688 static inline void thread_free_private_delcfs(CTXTdecl) {
02689
02690 DelCFptr next_delcf;
02691 DelCFptr delcf = private_delcf_chain_begin;
02692
02693 while (delcf) {
02694 next_delcf = DCF_NextDCF(delcf);
02695 mem_dealloc(delcf,sizeof(DeletedClauseFrame),ASSERT_SPACE);
02696 delcf = next_delcf;
02697 }
02698 }
02699
02700
02701
02702
02703
02704 void free_private_prref(CTXTdeclc CPtr *p) {
02705
02706 if ( *(pb)p == tabletrysingle )
02707 {
02708 TIFptr mtTIF = (TIFptr) *(p+2);
02709 Free_Private_TIF(mtTIF);
02710
02711 mem_dealloc((pb)(*(p+6)), sizeof(PrRefData),ASSERT_SPACE);
02712 if (xsb_profiling_enabled)
02713 remove_prog_seg((pb)*(p+6));
02714 mem_dealloc((pb)p, FIXED_BLOCK_SIZE_FOR_TABLED_PRED,
02715 ASSERT_SPACE) ;
02716 }
02717 else {
02718 mem_dealloc((pb)p, sizeof(PrRefData),ASSERT_SPACE);
02719 if (xsb_profiling_enabled)
02720 remove_prog_seg((pb)p);
02721 }
02722 }
02723
02724 void retractall_prref(CTXTdeclc PrRef);
02725
02726 void thread_free_dyn_blks(CTXTdecl) {
02727 struct DispBlk_t *dispblk;
02728 PrRef prref0, prref;
02729
02730
02731 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
02732 for (dispblk=DispBlkHdr.firstDB ; dispblk != NULL ; dispblk=dispblk->NextDB) {
02733 if (th->tid <= dispblk->MaxThread) {
02734 prref0 = (PrRef)(&(dispblk->Thread0))[th->tid];
02735 if (prref0) {
02736 if (cell_opcode((CPtr *)prref0) == tabletrysingle)
02737 prref = (PrRef)((CPtr *)prref0)[6];
02738 else prref = prref0;
02739 retractall_prref(CTXTc prref);
02740 free_private_prref(CTXTc (CPtr *)prref0);
02741
02742 (&(dispblk->Thread0))[th->tid] = (CPtr) NULL;
02743 }
02744 }
02745 }
02746 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
02747 }
02748
02749
02750
02751 void release_private_dynamic_resources(CTXTdecl) {
02752 thread_free_private_delcfs(CTXT);
02753 thread_free_dyn_blks(CTXT);
02754 }
02755
02756 #endif
02757
02758
02759
02760
02761 static int really_delete_clause(ClRef Clause)
02762 {
02763 xsb_dbgmsg((LOG_RETRACT,
02764 "Really deleting clause(%p) op(%x) type(%d)",
02765 Clause, ClRefTryOpCode(Clause), ClRefType(Clause) )) ;
02766 switch( ClRefType(Clause) )
02767 {
02768 case UNINDEXED_CL:
02769 delete_from_sobchain(Clause) ;
02770 break ;
02771
02772 case INDEXED_CL:
02773 { int i, NI ;
02774 SOBRef sob ;
02775 CPtr IP ;
02776
02777 NI = ClRefNumInds(Clause) ;
02778 xsb_dbgmsg((LOG_RETRACT,
02779 "Really deleting clause (%p) size %d indexes %d",
02780 Clause, ClRefSize(Clause), NI )) ;
02781 delete_from_allchain(Clause) ;
02782
02783
02784 for( i = NI; i >= 1; i-- ) {
02785 IP = ClRefIndPtr(Clause, i);
02786 if (cell_opcode(IP) == dynnoop)
02787 sob = (SOBRef)IndRefNext(IP);
02788 else sob = NULL;
02789
02790 xsb_dbgmsg((LOG_RETRACT,
02791 "SOB(%d) - hash size %d - %d clauses",
02792 i, ClRefHashSize(sob), ClRefNumNonemptyBuckets(sob) ));
02793 xsb_dbgmsg((LOG_RETRACT,
02794 "Addr %p : prev %p : next %p",
02795 sob, ClRefNext(sob), ClRefPrev(sob) ));
02796 delete_from_hashchain(Clause,i,NI) ;
02797 if (sob && --ClRefNumNonemptyBuckets(sob) == 0)
02798 {
02799 xsb_dbgmsg((LOG_RETRACT,"deleting sob - %p", sob ));
02800 delete_from_sobchain(sob) ;
02801 mem_dealloc((pb)ClRefAddr(sob), ClRefSize(sob),ASSERT_SPACE);
02802 }
02803 }
02804 break ;
02805 }
02806 case SOB_RECORD:
02807 default :
02808 xsb_exit( "retract internal error!" ) ;
02809 }
02810 mem_dealloc((pb)ClRefAddr(Clause), ClRefSize(Clause),ASSERT_SPACE);
02811 if (xsb_profiling_enabled)
02812 remove_prog_seg((pb)Clause);
02813 return TRUE ;
02814 }
02815
02816
02817
02818 int determine_if_safe_to_delete(ClRef Clause) {
02819 byte opcode;
02820 int NI, i;
02821 CPtr IP;
02822
02823 if (clref_is_marked(Clause)) return FALSE;
02824
02825 opcode = ClRefTryOpCode(Clause);
02826 if ((opcode == trymeelse || opcode == dyntrymeelse)
02827 && clref_is_marked(ClRefNext(Clause))) {
02828 return FALSE;
02829 }
02830
02831 NI = ClRefNumInds(Clause) ;
02832
02833
02834 for( i = NI; i >= 1; i-- ) {
02835
02836 IP = ClRefIndPtr(Clause, i);
02837 if (cell_opcode(IP) == trymeelse || cell_opcode(IP) == dyntrymeelse) {
02838 if (clref_is_marked((ClRef) (IndRefNext(IP) - (4 * i)))) {
02839 return FALSE;
02840 }
02841 }
02842 }
02843 return TRUE;
02844 }
02845
02846
02847
02848 static void mark_for_deletion(CTXTdeclc ClRef Clause)
02849 {
02850
02851
02852 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
02853 switch( ClRefType(Clause) ) {
02854 case UNINDEXED_CL: {
02855 cell_opcode(ClRefEntryPoint(Clause)) = fail ;
02856 cell_operand1(ClRefEntryPoint(Clause)) = MARKED_FOR_DELETION;
02857 }
02858 break ;
02859 case INDEXED_CL: {
02860 cell_opcode(ClRefIEntryPoint(Clause,ClRefNumInds(Clause))) = fail ;
02861 cell_operand1(ClRefIEntryPoint(Clause,ClRefNumInds(Clause)))
02862 = MARKED_FOR_DELETION;
02863 }
02864 break ;
02865 case SOB_RECORD:
02866 xsb_exit( "retracting indexing record!" ) ;
02867 break ;
02868 default :
02869 xsb_exit( "retract internal error!" ) ;
02870 break ;
02871 }
02872 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
02873 }
02874
02875
02876
02877
02878
02879
02880
02881
02882
02883 static void retract_clause(CTXTdeclc ClRef Clause, Psc psc ) {
02884 PrRef prref;
02885 int really_deleted = 0;
02886
02887 mark_for_deletion(CTXTc Clause);
02888
02889 if ((flags[NUM_THREADS] == 1 || !get_shared(psc))
02890 && pflags[CLAUSE_GARBAGE_COLLECT] == 1 && !dyntabled_incomplete(CTXTc psc)) {
02891
02892 if (!mark_cpstack_retract(CTXTc Clause) &&
02893 determine_if_safe_to_delete(Clause)) {
02894
02895
02896 really_delete_clause(Clause);
02897 really_deleted = 1;
02898 }
02899 unmark_cpstack_retract(CTXT);
02900 }
02901 if (!really_deleted) {
02902
02903 prref = dynpredep_to_prref(CTXTc get_ep(psc));
02904
02905
02906 #ifndef MULTI_THREAD
02907 check_insert_private_delcf_clause(prref,psc,Clause);
02908 #else
02909 if (!get_shared(psc)) {
02910 check_insert_private_delcf_clause(CTXT, prref,psc,Clause);
02911 }
02912 else {
02913 check_insert_shared_delcf_clause(CTXT, prref,psc,Clause);
02914 }
02915 #endif
02916 }
02917 }
02918
02919
02920
02921
02922
02923
02924 ClRef previous_clref(ClRef Clause) {
02925 int numInds;
02926 byte opcode;
02927
02928 if (ClRefType(Clause) == INDEXED_CL) {
02929 opcode = ClRefTryOpCode(Clause);
02930 if (opcode == dynnoop || opcode == dyntrymeelse
02931 || opcode == noop || opcode == trymeelse) {
02932 numInds = ClRefNumInds(Clause);
02933 Clause = ClRefPrev(Clause);
02934 opcode = ClRefTryOpCode(Clause);
02935 while (opcode == dynnoop || opcode == dyntrymeelse
02936 || opcode == noop || opcode == trymeelse) {
02937 if (--numInds) {
02938 Clause = (ClRef)(((Cell *)ClRefPrev(Clause)) - 5);
02939 opcode = ClRefTryOpCode(Clause);
02940 } else return ClRefPrev(Clause);
02941 }
02942 Clause = ClRefPrev(Clause);
02943 while (ClRefType(Clause) == SOB_RECORD) {
02944 Clause = (ClRef)ClRefLastIndex(Clause);
02945 }
02946 } else Clause = ClRefPrev(Clause);
02947 } else {
02948 Clause = ClRefPrev(Clause);
02949 while (ClRefType(Clause) == SOB_RECORD) {
02950 Clause = (ClRef)ClRefLastIndex(Clause);
02951 }
02952 }
02953 return Clause;
02954 }
02955
02956 CPtr get_ClRefEntryPoint(ClRef Clause) {
02957 int numInds;
02958 if( ClRefType(Clause) != INDEXED_CL )
02959 return ClRefEntryPoint(Clause);
02960 else {
02961 numInds = ClRefNumInds(Clause) ;
02962 return ClRefIEntryPoint(Clause,numInds) ;
02963 }
02964 }
02965
02966 ClRef db_get_clause_code_space(PrRef Pred, ClRef Clause, CPtr *CodeBegAddr,
02967 CPtr *CodeEndAddr) {
02968 int IndexArg = 0;
02969 int IndexLev = 0;
02970
02971 do {
02972 if (Clause == NULL)
02973 Clause = first_clref(Pred,(prolog_term)NULL,&IndexLev,&IndexArg);
02974 else Clause = next_clref(Pred,Clause,(prolog_term)NULL,&IndexLev,&IndexArg);
02975 } while (Clause && !(ClRefNotRetracted(Clause)));
02976
02977 if (Clause != NULL) {
02978 *CodeBegAddr = get_ClRefEntryPoint(Clause);
02979 *CodeEndAddr = (CPtr)((pb)ClRefAddr(Clause) + ClRefSize(Clause));
02980 }
02981 return Clause;
02982 }
02983
02984
02985
02986
02987
02988 xsbBool db_get_last_clause( CTXTdecl
02989 )
02990 {
02991 PrRef Pred = (PrRef)ptoc_int(CTXTc 1);
02992 ClRef Clause;
02993 CPtr EntryPoint = 0;
02994
02995 Pred = dynpredep_to_prref(CTXTc Pred);
02996 if (!Pred) return FALSE;
02997
02998 if (Pred->LastClRef == (ClRef)Pred) return FALSE;
02999 Clause = Pred->LastClRef;
03000
03001 while (ClRefType(Clause) == SOB_RECORD) {
03002 Clause = (ClRef)ClRefLastIndex(Clause);
03003 }
03004
03005 while (Clause != (ClRef)Pred && !ClRefNotRetracted(Clause)) {
03006 Clause = previous_clref(Clause);
03007 }
03008
03009 if (Clause == (ClRef)Pred) return FALSE;
03010 EntryPoint = get_ClRefEntryPoint(Clause);
03011 ctop_int(CTXTc 2, (Integer)Clause);
03012 ctop_int(CTXTc 3, (Integer)ClRefType(Clause));
03013 ctop_int(CTXTc 4, (Integer)EntryPoint);
03014 return TRUE;
03015 }
03016
03017
03018
03019
03020
03021
03022
03023
03024
03025
03026
03027
03028
03029
03030
03031
03032
03033
03034
03035 xsbBool db_get_clause( CTXTdecl )
03036 {
03037 PrRef Pred = (PrRef)ptoc_int(CTXTc 4);
03038 int IndexLevel = 0, IndexArg = 0;
03039 ClRef Clause ;
03040 prolog_term Head = reg_term(CTXTc 5);
03041 CPtr EntryPoint = 0;
03042 Integer failed = ptoc_int(CTXTc 6) ;
03043
03044
03045
03046 xsb_dbgmsg((LOG_RETRACT_GC,
03047 "GET CLAUSE P-%p(%x) C-%p(%x) F-%p L-%p",
03048 Pred, *(pb)Pred, ptoc_int(CTXTc 1),
03049 ptoc_int(CTXTc 1) ? *(pb)(ptoc_int(CTXTc 1)) : 0,
03050 Pred->FirstClRef, Pred->LastClRef ));
03051
03052 Pred = dynpredep_to_prref(CTXTc Pred);
03053
03054 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03055 if( !(Pred) || (Pred->LastClRef == (ClRef)Pred) )
03056 { Clause = 0 ;
03057 goto set_outputs;
03058 }
03059
03060 Clause = (ClRef)ptoc_int(CTXTc 1);
03061 if (Clause == 0) {
03062 Clause = first_clref( Pred, Head, &IndexLevel, &IndexArg ) ;
03063 while (Clause && ClRefNotRetracted(Clause)==failed) {
03064 Clause = next_clref( Pred, Clause, Head, &IndexLevel, &IndexArg );
03065 }
03066 }
03067 else
03068 { IndexLevel = ptoc_int(CTXTc 2);
03069 IndexArg = ptoc_int(CTXTc 3);
03070
03071 do {
03072
03073
03074 Clause = next_clref( Pred, Clause, Head, &IndexLevel, &IndexArg );
03075 } while (Clause && ClRefNotRetracted(Clause)==failed ) ;
03076 }
03077
03078 set_outputs:
03079 if( Clause != 0 ) {
03080 if( ClRefType(Clause) == SOB_RECORD ) {
03081 xsb_exit("Error in get clause");
03082 }
03083 else EntryPoint = get_ClRefEntryPoint(Clause);
03084 }
03085 else
03086 EntryPoint = 0 ;
03087
03088 xsb_dbgmsg((LOG_RETRACT_GC,
03089 "GOT CLAUSE C-%p(%x)", Clause, Clause ? *(pb)Clause : 0 ));
03090 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03091
03092 ctop_int(CTXTc 7, (Integer)Clause ) ;
03093 ctop_int(CTXTc 8, Clause != 0 ? (Integer)ClRefType(Clause) : 4 ) ;
03094 ctop_int(CTXTc 9, (Integer)EntryPoint ) ;
03095 ctop_int(CTXTc 10, IndexLevel);
03096 ctop_int(CTXTc 11, IndexArg);
03097 return TRUE ;
03098 }
03099
03100
03101 xsbBool db_reclaim0( CTXTdecl )
03102 {
03103 ClRef Clause = (ClRef)ptoc_int(CTXTc 1) ;
03104
03105 mark_for_deletion(CTXTc Clause) ;
03106 return TRUE;
03107 }
03108
03109 xsbBool db_retract0( CTXTdecl )
03110 {
03111 ClRef clause = (ClRef)ptoc_int(CTXTc 1) ;
03112
03113
03114 int retract_nr = 0;
03115
03116 if (retract_nr) {
03117 mark_for_deletion(CTXTc clause);
03118 }
03119 else {
03120 Psc psc = (Psc)ptoc_int(CTXTc 3);
03121 retract_clause(CTXTc clause, psc ) ;
03122 }
03123 return TRUE;
03124 }
03125
03126
03127
03128
03129
03130
03131
03132
03133
03134
03135
03136
03137 static inline void allocate_prref_tab(CTXTdeclc Psc psc, PrRef *prref, pb *new_ep) {
03138 int Loc;
03139
03140 if (!(*prref = (PrRef)mem_alloc_nocheck(sizeof(PrRefData),ASSERT_SPACE)))
03141 xsb_exit("++Unrecoverable Error[XSB/Runtime]: [Resource] Out of memory (PrRef)");
03142
03143
03144
03145 if (xsb_profiling_enabled)
03146 add_prog_seg(psc,(byte *)*prref,sizeof(PrRefData));
03147
03148 Loc = 0 ;
03149 dbgen_inst_ppp(fail,*prref,&Loc) ;
03150
03151 PrRef_FirstClRef(*prref) = NULL;
03152 PrRef_LastClRef(*prref) = (ClRefHdr *)*prref;
03153 PrRef_Psc(*prref) = psc;
03154 PrRef_Mark(*prref) = 0;
03155 PrRef_DelCF(*prref) = NULL;
03156 if ( get_tabled(psc) )
03157 {
03158 TIFptr tip;
03159 CPtr tp;
03160 tip = New_TIF(CTXTc psc);
03161 tp = (CPtr)mem_alloc_nocheck(FIXED_BLOCK_SIZE_FOR_TABLED_PRED,ASSERT_SPACE) ;
03162 if (tp == NULL) {
03163 xsb_exit("++Unrecoverable Error[XSB/Runtime]: [Resource] Out of memory (PrRef)");
03164 }
03165 Loc = 0 ;
03166 dbgen_inst_ppvww(tabletrysingle,get_arity(psc),(tp+3),tip,tp,&Loc) ;
03167 dbgen_inst_pvv(allocate_gc,3,3,tp,&Loc) ;
03168 dbgen_inst_ppv(getVn,2,tp,&Loc) ;
03169 dbgen_inst_ppvw(calld,3,*prref,tp,&Loc) ;
03170 dbgen_inst_pvv(new_answer_dealloc,get_arity(psc),2,tp,&Loc) ;
03171 *new_ep = (pb)tp;
03172 }
03173 else *new_ep = (pb)*prref;
03174 }
03175
03176
03177 PrRef build_prref( CTXTdeclc Psc psc )
03178 {
03179 PrRef p;
03180 pb new_ep;
03181
03182
03183 set_type(psc, T_DYNA);
03184 set_env(psc, T_VISIBLE);
03185
03186
03187 if (get_data(psc) == NULL)
03188 set_data(psc,global_mod);
03189
03190 allocate_prref_tab(CTXTc psc,&p,&new_ep);
03191 p->psc = psc;
03192 p-> mark = 0;
03193
03194 #ifdef MULTI_THREAD
03195
03196
03197
03198 if ((*(pb)get_ep(psc) == switchonthread) || !get_shared(psc)) {
03199 struct DispBlk_t *dispblk;
03200 if (*(pb)get_ep(psc) != switchonthread) {
03201
03202 pb disp_instr_addr = mem_calloc(sizeof(Cell),2,MT_PRIVATE_SPACE);
03203 dispblk = (struct DispBlk_t *)
03204 mem_calloc(sizeof(struct DispBlk_t)+MAX_THREADS*sizeof(Cell),
03205 1,MT_PRIVATE_SPACE);
03206
03207 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03208 if (DispBlkHdr.firstDB) DispBlkHdr.firstDB->PrevDB = dispblk;
03209 dispblk->NextDB = DispBlkHdr.firstDB;
03210 DispBlkHdr.firstDB = dispblk;
03211 if (!DispBlkHdr.lastDB) DispBlkHdr.lastDB = dispblk;
03212 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03213
03214 dispblk->MaxThread = MAX_THREADS;
03215 *disp_instr_addr = switchonthread;
03216 *(((CPtr *)disp_instr_addr)+1) = (CPtr)dispblk;
03217 set_ep(psc,disp_instr_addr);
03218 } else {
03219
03220 dispblk = (struct DispBlk_t *)*((CPtr)get_ep(psc)+1);
03221 }
03222 if (dispblk->MaxThread >= th->tid) {
03223 (&(dispblk->Thread0))[th->tid] = (CPtr)new_ep;
03224 } else xsb_exit("must expand dispatch-block");
03225 } else set_ep(psc,new_ep);
03226 #else
03227 set_ep(psc,new_ep);
03228 #endif
03229 return p;
03230 }
03231
03232 xsbBool db_build_prref( CTXTdecl ) {
03233
03234 ctop_int(CTXTc 3, (Integer)build_prref(CTXTc (Psc)ptoc_int(CTXTc 1)));
03235 return TRUE;
03236 }
03237
03238
03239 PrRef get_prref(CTXTdeclc Psc psc) {
03240 PrRef prref;
03241 if (get_ep(psc) == (byte *)&fail_inst) {
03242 prref = build_prref(CTXTc psc);
03243 } else {
03244 prref = dynpredep_to_prref(CTXTc get_ep(psc));
03245 #ifdef MULTI_THREAD
03246
03247 if (!prref) {
03248 pb new_ep;
03249 struct DispBlk_t *dispblk = ((struct DispBlk_t **)get_ep(psc))[1];
03250 allocate_prref_tab(CTXTc psc,&prref,&new_ep);
03251 if (dispblk->MaxThread >= th->tid) {
03252 (&(dispblk->Thread0))[th->tid] = (CPtr) new_ep;
03253 } else {
03254
03255 xsb_exit("must expand dispatch-block");
03256 }
03257 }
03258
03259 #endif
03260 }
03261 return prref;
03262 }
03263
03264 xsbBool db_get_prref( CTXTdecl ) {
03265 ctop_int(CTXTc 2,(Integer)get_prref(CTXTc (Psc)ptoc_int(CTXTc 1)));
03266 return TRUE;
03267 }
03268
03269
03270
03271
03272
03273 void free_prref(CTXTdeclc CPtr *p, Psc psc) {
03274
03275 if ( *(pb)p == tabletrysingle )
03276 {
03277 TIFptr mtTIF = (TIFptr) *(p+2);
03278 #ifdef MULTI_THREAD
03279 if (!get_shared(psc)) {
03280 Free_Private_TIF(mtTIF);
03281 }
03282 else {
03283 Free_Shared_TIF(mtTIF);
03284 }
03285 #else
03286 Free_Shared_TIF(mtTIF);
03287 #endif
03288
03289 mem_dealloc((pb)(*(p+6)), sizeof(PrRefData),ASSERT_SPACE);
03290 if (xsb_profiling_enabled)
03291 remove_prog_seg((pb)*(p+6));
03292 mem_dealloc((pb)p, FIXED_BLOCK_SIZE_FOR_TABLED_PRED,ASSERT_SPACE) ;
03293 }
03294 else {
03295 mem_dealloc((pb)p, sizeof(PrRefData),ASSERT_SPACE);
03296 if (xsb_profiling_enabled)
03297 remove_prog_seg((pb)p);
03298 }
03299 }
03300
03301
03302 PrRef sob_to_prref(ClRef clref) {
03303 while (ClRefTryOpCode(clref) == dynretrymeelse) {
03304
03305
03306 clref = ClRefPrev(clref);
03307 }
03308 switch (ClRefTryOpCode(clref)) {
03309 case dynnoop:
03310 case noop:
03311 case dyntrymeelse:
03312 case trymeelse:
03313 return (PrRef)ClRefPrev(clref);
03314 case dyntrustmeelsefail:
03315 return (PrRef)ClRefNext(clref);
03316 }
03317 return NULL;
03318 }
03319
03320
03321 #ifdef UNDEFINED
03322 PrRef clref_to_prref(ClRef clref) {
03323 CPtr curInd;
03324 if (ClRefType(clref) == UNINDEXED_CL) {
03325 return sob_to_prref(clref);
03326 } else if (ClRefType(clref) == INDEXED_CL) {
03327 curInd = ClRefIndPtr(clref,1);
03328 if (ClRefTryOpCode(curInd) != dynnoop) {
03329 while (cell_opcode(curInd) != dyntrustmeelsefail) {
03330 curInd = IndRefNext(curInd);
03331 }
03332 }
03333 return sob_to_prref((SOBRef)IndRefNext(curInd));
03334 } else return NULL;
03335 }
03336 #endif
03337
03338 PrRef clref_to_prref(ClRef clref) {
03339 CPtr curInd;
03340 if (ClRefType(clref) == UNINDEXED_CL || ClRefType(clref) == SOB_RECORD) {
03341 return sob_to_prref(clref);
03342 } else if (ClRefType(clref) == INDEXED_CL) {
03343 curInd = ClRefIndPtr(clref,1);
03344 if (ClRefTryOpCode(curInd) != dynnoop) {
03345 while (cell_opcode(curInd) != dyntrustmeelsefail) {
03346 curInd = IndRefNext(curInd);
03347 }
03348 }
03349 return sob_to_prref((SOBRef)IndRefNext(curInd));
03350 } else return NULL;
03351 }
03352
03353
03354
03355
03356
03357
03358 #define clref_fld(x) ((CPtr) *(x +1))
03359 #define next_clref(x) ((CPtr) *(x +1))
03360 #define last_clref(PRREF) ((CPtr)((PrRef)(PRREF))->LastClRef)
03361 #define try_type_instr_fld(x) (ClRefTryOpCode(x))
03362 #define code_to_run(x) (cell_opcode(ClRefEntryPoint(x)))
03363 #define first_instr_to_run(x) (cell_opcode(ClRefWord(x,3)))
03364
03365
03366
03367 static inline int clref_trie_asserted(CPtr Clref) {
03368 return((code_to_run(Clref) == jump) &&
03369 (first_instr_to_run(Clref) == trie_assert_inst));
03370 }
03371
03372
03373
03374
03375
03376 static void abolish_trie_asserted_stuff(CTXTdeclc PrRef prref) {
03377
03378 BTNptr pRoot;
03379 CPtr b;
03380
03381
03382 b = (CPtr)prref->FirstClRef;
03383 pRoot = (BTNptr)*(b + 3);
03384 switch_to_trie_assert;
03385 delete_trie(CTXTc pRoot);
03386 switch_from_trie_assert;
03387 *(pb)prref = fail;
03388 mem_dealloc((pb)(b-2),6*sizeof(Cell),ASSERT_SPACE);
03389 }
03390
03391
03392
03393 static int another_buff(Cell Instr)
03394 {
03395 int op = cell_opcode(&Instr) ;
03396 return (op != dynnoop && op != dyntrustmeelsefail && op != fail
03397 && op != noop);
03398 }
03399
03400
03401
03402
03403
03404
03405 #define MAXDYNFREEBUFF 200
03406
03407
03408 void retractall_prref(CTXTdeclc PrRef prref) {
03409 int btop = 0;
03410 ClRef buffer;
03411 ClRef buffers_to_free[MAXDYNFREEBUFF];
03412
03413 if (prref && (cell_opcode((CPtr)prref) != fail)) {
03414 if (PredOpCode(prref) == jump) {
03415 abolish_trie_asserted_stuff(CTXTc prref);
03416 return;
03417 }
03418 buffers_to_free[btop++] = prref->FirstClRef;
03419 while (btop > 0) {
03420 if (btop >= MAXDYNFREEBUFF) xsb_exit("Too many buffers to retract");
03421 buffer = buffers_to_free[--btop];
03422 switch (ClRefType(buffer)) {
03423 case SOB_RECORD:
03424 if (another_buff(ClRefJumpInstr(buffer)))
03425 buffers_to_free[btop++] = (ClRef) ClRefFirstIndex(buffer);
03426 if (another_buff(ClRefTryInstr(buffer)))
03427 buffers_to_free[btop++] = ClRefNext(buffer);
03428 mem_dealloc((pb)ClRefAddr(buffer),ClRefSize(buffer),ASSERT_SPACE);
03429 if (xsb_profiling_enabled)
03430 remove_prog_seg((pb)buffer);
03431 break ;
03432 case UNINDEXED_CL:
03433 case INDEXED_CL:
03434 if (another_buff(ClRefTryInstr(buffer)))
03435 buffers_to_free[btop++] = ClRefNext(buffer);
03436 if( ClRefNotRetracted(buffer) ) {
03437
03438
03439 mem_dealloc((pb)ClRefAddr(buffer),ClRefSize(buffer),ASSERT_SPACE);
03440 if (xsb_profiling_enabled)
03441 remove_prog_seg((pb)buffer);
03442 }
03443 break;
03444 }
03445 }
03446 PrRef_FirstClRef(prref) = NULL;
03447 cell_opcode((CPtr)prref) = fail;
03448 }
03449 }
03450
03451
03452
03453
03454
03455
03456 void gc_retractall(CTXTdeclc ClRef clref) {
03457 int btop = 0;
03458 ClRef buffer;
03459 ClRef buffers_to_free[MAXDYNFREEBUFF];
03460
03461 buffers_to_free[btop++] = clref;
03462 while (btop > 0) {
03463 if (btop >= MAXDYNFREEBUFF) xsb_exit("Too many buffers to retract");
03464 buffer = buffers_to_free[--btop];
03465 switch (ClRefType(buffer)) {
03466 case SOB_RECORD:
03467 if (another_buff(ClRefJumpInstr(buffer)))
03468 buffers_to_free[btop++] = (ClRef) ClRefFirstIndex(buffer);
03469 if (another_buff(ClRefTryInstr(buffer)))
03470 buffers_to_free[btop++] = ClRefNext(buffer);
03471 mem_dealloc((pb)ClRefAddr(buffer),ClRefSize(buffer),ASSERT_SPACE);
03472 if (xsb_profiling_enabled)
03473 remove_prog_seg((pb)buffer);
03474 break ;
03475 case UNINDEXED_CL:
03476 case INDEXED_CL:
03477 if (another_buff(ClRefTryInstr(buffer)))
03478 buffers_to_free[btop++] = ClRefNext(buffer);
03479 if( ClRefNotRetracted(buffer) ) {
03480
03481
03482 mem_dealloc((pb)ClRefAddr(buffer),ClRefSize(buffer),ASSERT_SPACE);
03483 if (xsb_profiling_enabled)
03484 remove_prog_seg((pb)buffer);
03485 }
03486 break;
03487 }
03488 }
03489 }
03490
03491
03492
03493
03494
03495
03496
03497
03498
03499
03500
03501 int gen_retract_all(CTXTdecl)
03502 {
03503 PrRef prref = (PrRef)ptoc_int(CTXTc 1);
03504 Psc psc = (Psc)ptoc_int(CTXTc 2);
03505 int action = 0;
03506
03507 prref = dynpredep_to_prref(CTXTc prref);
03508
03509
03510
03511
03512 if (!prref || PrRef_FirstClRef(prref) == NULL) {
03513 return TRUE;
03514 }
03515
03516 if ((flags[NUM_THREADS] == 1 || !get_shared(psc))
03517 && pflags[CLAUSE_GARBAGE_COLLECT] == 1 && !dyntabled_incomplete(CTXTc psc)) {
03518
03519 gc_dynamic(CTXT);
03520
03521 action = check_cpstack_retractall(CTXTc prref);
03522 } else action = 1;
03523 if (!action) {
03524 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03525
03526 retractall_prref(CTXTc prref);
03527 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03528 }
03529 else {
03530
03531
03532 #ifndef MULTI_THREAD
03533 check_insert_private_delcf_pred(prref,psc);
03534 #else
03535 if (!get_shared(psc)) {
03536 check_insert_private_delcf_pred(CTXT, prref,psc);
03537 }
03538 else {
03539 check_insert_shared_delcf_pred(CTXT, prref,psc);
03540 }
03541 #endif
03542 PrRef_FirstClRef(prref) = NULL;
03543 cell_opcode((CPtr)prref) = fail;
03544 }
03545 return TRUE;
03546 }
03547
03548
03549
03550
03551
03552
03553
03554
03555
03556
03557
03558
03559
03560
03561
03562
03563
03564
03565
03566
03567
03568
03569
03570 void db_remove_prref_1( CTXTdeclc Psc psc )
03571 {
03572 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03573 if (get_ep(psc) != ((byte *)(&(psc->load_inst)))) {
03574 free_prref(CTXTc (CPtr *)get_ep(psc),psc);
03575 set_type(psc, T_ORDI);
03576 set_ep(psc, ((byte *)(&(psc->load_inst))));
03577 }
03578 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03579 }
03580
03581 xsbBool db_abolish0(CTXTdecl)
03582 {
03583 PrRef prref = (PrRef)ptoc_int(CTXTc 1);
03584 Psc psc = (Psc)ptoc_int(CTXTc 2);
03585 int action = 0;
03586
03587 prref = dynpredep_to_prref(CTXTc prref);
03588
03589 if (!prref) return TRUE;
03590
03591 if (flags[NUM_THREADS] != 1) {
03592 xsb_abort("Cannot abolish a predicate when more than 1 thread is active");
03593 }
03594
03595 if (get_tabled(psc)) {
03596 if (!is_completed_table(get_tip(CTXTc psc))) {
03597 xsb_table_error(CTXTc
03598 "Cannot abolish tabled predicate when table is incomplete");
03599 } else fast_abolish_table_predicate(CTXTc psc);
03600 }
03601
03602 gc_dynamic(CTXT);
03603
03604 action = check_cpstack_retractall(CTXTc prref);
03605 if (!action) {
03606 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03607
03608 retractall_prref(CTXTc prref);
03609 db_remove_prref_1( CTXTc psc);
03610 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03611 }
03612 else {
03613 xsb_abort("Cannot abolish a predicate with active backtrack points: use retractall");
03614 }
03615 return TRUE;
03616 }
03617
03618
03619
03620
03621
03622
03623
03624
03625
03626 static void retractall_clause(CTXTdeclc ClRef Clause, Psc psc, int flag ) {
03627 PrRef prref;
03628 int really_deleted = 0;
03629
03630
03631 mark_for_deletion(CTXTc Clause);
03632
03633 if ((flags[NUM_THREADS] == 1 || !get_shared(psc))
03634 && pflags[CLAUSE_GARBAGE_COLLECT] == 1
03635 && !dyntabled_incomplete(CTXTc psc) && !flag) {
03636
03637 if(!(clref_is_marked(Clause)) &&
03638 determine_if_safe_to_delete(Clause)) {
03639 really_delete_clause(Clause);
03640 really_deleted = 1;
03641 }
03642 }
03643 if (!really_deleted) {
03644
03645 prref = dynpredep_to_prref(CTXTc get_ep(psc));
03646
03647
03648 #ifndef MULTI_THREAD
03649 check_insert_private_delcf_clause(prref,psc,Clause);
03650 #else
03651 if (!get_shared(psc)) {
03652 check_insert_private_delcf_clause(CTXT, prref,psc,Clause);
03653 }
03654 else {
03655 check_insert_shared_delcf_clause(CTXT, prref,psc,Clause);
03656 }
03657 #endif
03658 }
03659 }
03660
03661
03662
03663 void db_retractall0( CTXTdecl )
03664 {
03665 ClRef clause = (ClRef)ptoc_int(CTXTc 2) ;
03666 int cantReclaim = (int)ptoc_int(CTXTc 3) ;
03667
03668 Psc psc = (Psc)ptoc_int(CTXTc 4);
03669 retractall_clause(CTXTc clause, psc, cantReclaim ) ;
03670 }
03671
03672
03673
03674
03675
03676
03677
03678 void init_dbclause_cgc_blocks(void) {
03679 Psc psc;
03680 int new;
03681
03682 psc = ((Pair)insert("db_get_clauses1", 11,
03683 pair_psc(insert_module(0, "dbclause")), &new)) -> psc_ptr;
03684 dbclause_cgc_block_gl = (CPtr) (get_ep(psc) + 0xc8);
03685 }
03686
03687 void init_standard_cgc_blocks(void) {
03688 Psc psc;
03689 int new;
03690
03691 psc = ((Pair)insert(";", 2,
03692 pair_psc(insert_module(0, "standard")), &new))-> psc_ptr;
03693 standard_cgc_block_begin_gl = (CPtr) (get_ep(psc));
03694 standard_cgc_block_end_gl = (CPtr) (get_ep(psc) + 0x94);
03695 }
03696
03697
03698 xsbBool dynamic_code_function( CTXTdecl )
03699 {
03700 switch (ptoc_int(CTXTc 1)) {
03701
03702 case MARK_CPSTACK_RETRACTALL:
03703 ctop_int(CTXTc 2,mark_cpstack_retractall(CTXT));
03704 break;
03705
03706 case UNMARK_CPSTACK_RETRACT:
03707 unmark_cpstack_retract(CTXT);
03708 break;
03709
03710 case DB_RETRACTALL0:
03711 db_retractall0(CTXT);
03712 break;
03713
03714 case INIT_DBCLAUSE_CGC_BLOCKS:
03715 init_dbclause_cgc_blocks();
03716 break;
03717
03718 case INIT_STANDARD_CGC_BLOCKS:
03719 init_standard_cgc_blocks();
03720 break;
03721
03722 }
03723
03724 return TRUE;
03725 }
03726
03727
03728
03729
03730
03731 static inline CPtr trie_asserted_clref(CPtr prref)
03732 {
03733 CPtr Clref;
03734
03735 Clref = last_clref(prref);
03736 if (try_type_instr_fld(prref) != fail) {
03737 if ((code_to_run(Clref) == jump) &&
03738 (first_instr_to_run(Clref) == trie_assert_inst))
03739 return Clref;
03740 }
03741 return NULL;
03742 }
03743
03744
03745
03746
03747 static inline void print_bytes(CPtr x, int lo, int hi)
03748 {
03749 int i;
03750
03751 xsb_dbgmsg((LOG_DEBUG, "addr %p ---------------------------------",x));
03752 for (i = lo; i <= hi ; i++) {
03753 xsb_dbgmsg((LOG_DEBUG," i = %d 4*i = %d x[i] = %x ",i,4*i, (int)*(x+i)));
03754 }
03755 xsb_dbgmsg((LOG_DEBUG, "Instr = %s ---code to run %s----",
03756 (char *)inst_table[try_type_instr_fld(x)][0],
03757 (char *)inst_table[code_to_run(x)][0] ));
03758 }
03759
03760
03761
03762 BTNptr trie_asserted_trienode(CPtr clref) {
03763 if ((ClRefType(clref) == TRIE_CL) && clref_trie_asserted(clref))
03764 return((BTNptr)*(clref + 3));
03765 else return NULL;
03766 }
03767
03768
03769
03770 int trie_assert(CTXTdecl)
03771 {
03772 Cell Clause;
03773 Psc psc;
03774 CPtr Prref;
03775 #ifdef DEBUG_VERBOSE
03776 int Arity;
03777 #endif
03778 CPtr Trie_Asserted_Clref = NULL;
03779 BTNptr inst_node_ptr;
03780 int found = 1;
03781
03782 Clause = reg_term(CTXTc 1);
03783 psc = (Psc)ptoc_int(CTXTc 2);
03784 Prref = (CPtr)ptoc_int(CTXTc 4);
03785
03786 #ifdef DEBUG_VERBOSE
03787 Arity = ptoc_int(CTXTc 3);
03788 xsb_dbgmsg((LOG_DEBUG,"Prref bytes\n"));
03789 if (cur_log_level >= LOG_DEBUG)
03790 print_bytes(Prref,-2,2);
03791 xsb_dbgmsg((LOG_DEBUG,"Clause :"));
03792 dbg_printterm(LOG_DEBUG,stddbg,Clause,24);
03793 xsb_dbgmsg((LOG_DEBUG," Arity %d ", Arity));
03794 xsb_dbgmsg((LOG_DEBUG," Psc %d ",(int)psc));
03795 xsb_dbgmsg((LOG_DEBUG," Prref %d ",(int)Prref));
03796 xsb_dbgmsg((LOG_DEBUG,"\n"));
03797 #endif
03798
03799 Trie_Asserted_Clref = trie_asserted_clref(Prref);
03800
03801 xsb_dbgmsg((LOG_ASSERT, " Trie_Asserted_Clref %p",Trie_Asserted_Clref));
03802
03803 switch_to_trie_assert;
03804 SYS_MUTEX_LOCK( MUTEX_DYNAMIC );
03805 if(Trie_Asserted_Clref == NULL){
03806
03807
03808
03809
03810 Trie_Asserted_Clref = ((CPtr)mem_alloc(6*sizeof(Cell),ASSERT_SPACE)) + 2;
03811 *(Trie_Asserted_Clref-2) = 6*sizeof(Cell)+TRIE_CL;
03812 *(byte *)(Trie_Asserted_Clref +2) = jump;
03813
03814 inst_node_ptr = newBasicTrie(CTXTc EncodeTriePSC(psc),ASSERT_TRIE_TT);
03815 Instr(inst_node_ptr) = trie_assert_inst;
03816
03817 *(Trie_Asserted_Clref +3) = (Cell)inst_node_ptr;
03818
03819 db_addbuff((byte)(get_arity(psc) + 1),(ClRef)Trie_Asserted_Clref,(PrRef)Prref,1,TRUE,2);
03820 }
03821 else
03822 inst_node_ptr = (BTNptr)*(Trie_Asserted_Clref +3);
03823
03824 one_term_chk_ins(CTXTc (CPtr)Clause,inst_node_ptr,&found);
03825 SYS_MUTEX_UNLOCK( MUTEX_DYNAMIC );
03826 switch_from_trie_assert;
03827 ctop_int(CTXTc 5,found);
03828 return TRUE;
03829 }
03830
03831
03832
03833
03834
03835
03836
03837
03838
03839
03840
03841
03842
03843
03844
03845
03846
03847
03848
03849
03850
03851
03852
03853
03854
03855 int trie_retract(CTXTdecl)
03856 {
03857 CPtr Clref;
03858 BTNptr inst_node_ptr;
03859
03860 Clref = (CPtr)ptoc_int(CTXTc 1);
03861 if (Clref == NULL) {
03862 Last_Nod_Sav = NULL;
03863 return TRUE;
03864 }
03865 else if (Last_Nod_Sav == NULL) {
03866 xsb_dbgmsg((LOG_DEBUG,"Last_Nod_Sav is NULL "));
03867 return FALSE;
03868 }
03869 else {
03870 inst_node_ptr = (BTNptr)*(Clref +3);
03871 xsb_dbgmsg((LOG_DEBUG, " Deleting from Instrn Node %p", inst_node_ptr ));
03872 xsb_dbgmsg((LOG_DEBUG,
03873 " Before: Child of Instrn Node %p", Child(inst_node_ptr)));
03874 switch_to_trie_assert;
03875 delete_branch(CTXTc Last_Nod_Sav, &(Child(inst_node_ptr)));
03876 switch_from_trie_assert;
03877 xsb_dbgmsg((LOG_DEBUG,
03878 " After : Child of Instrn Node %p", Child(inst_node_ptr)));
03879 return TRUE;
03880 }
03881 }
03882
03883
03884
03885
03886
03887 int trie_retract_safe(CTXTdecl)
03888 {
03889 if (Last_Nod_Sav == NULL)
03890 return FALSE;
03891 else {
03892 safe_delete_branch(Last_Nod_Sav);
03893 return TRUE;
03894 }
03895 }
03896
