int return_scc_list(CTXTdeclc SCCNode * nodes, int num_nodes){
VariantSF subgoal;
TIFptr tif;
int cur_node = 0,arity, j;
Psc psc;
CPtr oldhreg = NULL;
reg[4] = makelist(hreg);
new_heap_free(hreg); new_heap_free(hreg);
do {
subgoal = (VariantSF) nodes[cur_node].node;
tif = (TIFptr) subgoal->tif_ptr;
psc = TIF_PSC(tif);
arity = get_arity(psc);
// printf("subgoal %p, %s/%d\n",subgoal,get_name(psc),arity);
check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args..
oldhreg=hreg-2; // ptr to car
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(sreg);
new_heap_functor(sreg,get_ret_psc(2)); // car pts to ret/2 psc
hreg += 3; // hreg pts past ret/2
sreg = hreg;
follow(hreg-1) = makeint(nodes[cur_node].component); // arg 2 of ret/2 pts to component
follow(hreg-2) = makecs(sreg);
new_heap_functor(sreg, psc); // arg 1 of ret/2 pts to goal psc
hreg += arity + 1;
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
} else{
follow(oldhreg++) = makestring(get_name(psc));
}
follow(oldhreg) = makelist(hreg); // cdr points to next car
new_heap_free(hreg); new_heap_free(hreg);
cur_node++;
} while (cur_node < num_nodes);
follow(oldhreg) = makenil; // cdr points to next car
return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
/*
For a callnode call1 returns a Prolog list of callnode on which call1
immediately depends.
*/
int immediate_inedges_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j, count = 0,arity;
Psc psc;
CPtr oldhreg = NULL;
calllistptr cl;
reg[4] = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
cl= call1->inedges;
while(IsNonNULL(cl)){
subgoal = (VariantSF) cl->inedge_node->callnode->goal;
if(IsNonNULL(subgoal)){/* fact check */
count++;
tif = (TIFptr) subgoal->tif_ptr;
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg = hreg-2;
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(hreg);
hreg += arity + 1;
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
}else{
follow(oldhreg++) = makestring(get_name(psc));
}
follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
cl=cl->next;
}
if (count>0)
follow(oldhreg) = makenil;
else
reg[4] = makenil;
}else{
xsb_warn("Called with non-incremental predicate\n");
reg[4] = makenil;
}
return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
Pair build_call(CTXTdeclc Psc psc)
{
register Cell arg;
register Pair callstr;
register int i;
callstr = (Pair)hreg; /* save addr of new structure rec */
new_heap_functor(hreg, psc); /* set str psc ptr */
for (i=1; i <= (int)get_arity(psc); i++) {
arg = cell(reg+i);
nbldval(arg);
}
return callstr;
}
int immediate_outedges_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j, count = 0,arity;
Psc psc;
CPtr oldhreg = NULL;
struct hashtable *h;
struct hashtable_itr *itr;
callnodeptr cn;
reg[4] = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */
h=call1->outedges->hasht;
itr = hashtable1_iterator(h);
if (hashtable1_count(h) > 0){
do {
cn = hashtable1_iterator_value(itr);
if(IsNonNULL(cn->goal)){
count++;
subgoal = (VariantSF) cn->goal;
tif = (TIFptr) subgoal->tif_ptr;
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg=hreg-2;
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(sreg);
hreg += arity + 1;
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
}else{
follow(oldhreg++) = makestring(get_name(psc));
}
follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
} while (hashtable1_iterator_advance(itr));
}
if (count>0)
follow(oldhreg) = makenil;
else
reg[4] = makenil;
}else{
xsb_warn("Called with non-incremental predicate\n");
reg[4] = makenil;
}
// printterm(stdout,call_list,100);
return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4));
}
int create_lazy_call_list(CTXTdeclc callnodeptr call1){
VariantSF subgoal;
TIFptr tif;
int j,count=0,arity;
Psc psc;
CPtr oldhreg=NULL;
// print_call_list(lazy_affected);
reg[6] = reg[5] = makelist(hreg); // reg 5 first not-used, use regs in case of stack expanson
new_heap_free(hreg); // make heap consistent
new_heap_free(hreg);
while((call1 = delete_calllist_elt(&lazy_affected)) != EMPTY){
subgoal = (VariantSF) call1->goal;
// fprintf(stddbg," considering ");print_subgoal(stdout,subgoal);printf("\n");
if(IsNULL(subgoal)){ /* fact predicates */
call1->deleted = 0;
continue;
}
if (subg_visitors(subgoal)) {
sprint_subgoal(CTXTc forest_log_buffer_1,0,subgoal);
#ifdef ISO_INCR_TABLING
find_the_visitors(CTXTc subgoal);
#else
#ifdef WARN_ON_UNSAFE_UPDATE
xsb_warn("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n",
subg_visitors(subgoal),forest_log_buffer_1->fl_buffer);
#else
xsb_abort("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n",
subg_visitors(subgoal),forest_log_buffer_1->fl_buffer);
#endif
#endif
continue;
}
// fprintf(stddbg,"adding dependency for ");print_subgoal(stdout,subgoal);printf("\n");
count++;
tif = (TIFptr) subgoal->tif_ptr;
// if (!(psc = TIF_PSC(tif)))
// xsb_table_error(CTXTc "Cannot access dynamic incremental table\n");
psc = TIF_PSC(tif);
arity = get_arity(psc);
check_glstack_overflow(6,pcreg,2+arity*200); // don't know how much for build_subgoal_args...
oldhreg = clref_val(reg[6]); // maybe updated by re-alloc
if(arity>0){
sreg = hreg;
follow(oldhreg++) = makecs(sreg);
hreg += arity + 1; // had 10, why 10? why not 3? 2 for list, 1 for functor (dsw)
new_heap_functor(sreg, psc);
for (j = 1; j <= arity; j++) {
new_heap_free(sreg);
cell_array1[arity-j] = cell(sreg-1);
}
build_subgoal_args(subgoal);
} else {
follow(oldhreg++) = makestring(get_name(psc));
}
reg[6] = follow(oldhreg) = makelist(hreg);
new_heap_free(hreg);
new_heap_free(hreg);
}
if(count > 0) {
follow(oldhreg) = makenil;
hreg -= 2; /* take back the extra words allocated... */
} else
reg[5] = makenil;
return unify(CTXTc reg_term(CTXTc 4),reg_term(CTXTc 5));
/*int i;
for(i=0;i<callqptr;i++){
if(IsNonNULL(callq[i]) && (callq[i]->deleted==1)){
sfPrintGoal(stdout,(VariantSF)callq[i]->goal,NO);
printf(" %d %d\n",callq[i]->falsecount,callq[i]->deleted);
}
}
printf("-----------------------------\n"); */
}
/* caller must ensure enough heap space (term_size(term)*sizeof(Cell)) */
prolog_term intern_term(CTXTdeclc prolog_term term) {
Integer ti = 0;
Cell arg, newterm, interned_term, orig_term;
unsigned int subterm_index;
XSB_Deref(term);
if (!(islist(term) || isconstr(term))) {return term;}
if (isinternstr(term)) {return term;}
if (is_cyclic(CTXTc term)) {xsb_abort("Cannot intern a cyclic term\n");}
// if (!ground(term)) {return term;}
orig_term = term;
// printf("iti: ");printterm(stdout,orig_term,100);printf("\n");
if (!ts_array) {
ts_array = mem_alloc(init_ts_array_len*sizeof(*ts_array),OTHER_SPACE);
if (!ts_array) xsb_abort("No space for interning term\n");
ts_array_len = init_ts_array_len;
}
ts_array[0].term = term;
if (islist(term)) {
ts_array[0].subterm_index = 0;
ts_array[0].newterm = makelist(hreg);
hreg += 2;
}
else {
// if (isboxedinteger(term)) printf("interning boxed int\n");
// else if (isboxedfloat(term)) printf("interning boxed float %f\n",boxedfloat_val(term));
ts_array[0].subterm_index = 1;
ts_array[0].newterm = makecs(hreg);
new_heap_functor(hreg, get_str_psc(term));
hreg += get_arity(get_str_psc(term));
}
ts_array[ti].ground = 1;
while (ti >= 0) {
term = ts_array[ti].term;
newterm = ts_array[ti].newterm;
subterm_index = ts_array[ti].subterm_index;
if ((islist(term) && subterm_index >= 2) ||
(isconstr(term) && subterm_index > get_arity(get_str_psc(term)))) {
if (ts_array[ti].ground) {
interned_term = intern_rec(CTXTc newterm);
if (!interned_term) xsb_abort("error term should have been interned\n");
hreg = clref_val(newterm); // reclaim used stack space
if (!ti) {
if (compare(CTXTc (void*)orig_term,(void*)interned_term) != 0) printf("NOT SAME\n");
//printf("itg: ");printterm(stdout,interned_term,100);printf("\n");
return interned_term;
}
ti--;
get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = interned_term;
} else {
//printf("hreg = %p, ti=%d\n",hreg,ti);
if (!ti) {
if (compare(CTXTc (void*)orig_term,(void*)newterm) != 0) printf("NOT SAME\n");
//printf("ito: ");printterm(stdout,newterm,100);printf("\n");
return newterm;
}
ti--;
get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = newterm;
ts_array[ti].ground = 0;
}
} else {
arg = get_str_arg(term, (ts_array[ti].subterm_index)++);
XSB_Deref(arg);
switch (cell_tag(arg)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
ts_array[ti].ground = 0;
get_str_arg(newterm,subterm_index) = arg;
break;
case XSB_STRING:
if (string_find_safe(string_val(arg)) != string_val(arg)) printf("uninterned string?\n");
case XSB_INT:
case XSB_FLOAT:
get_str_arg(newterm,subterm_index) = arg;
break;
case XSB_LIST:
if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
else {
ti++;
check_ts_array_overflow;
ts_array[ti].term = arg;
ts_array[ti].subterm_index = 0;
ts_array[ti].ground = 1;
ts_array[ti].newterm = makelist(hreg);
hreg += 2;
}
break;
case XSB_STRUCT:
if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
else {
// if (isboxedinteger(arg)) printf("interning boxed int\n");
// else if (isboxedfloat(arg)) printf("interning boxed float %f\n",boxedfloat_val(arg));
ti++;
check_ts_array_overflow;
ts_array[ti].term = arg;
ts_array[ti].subterm_index = 1;
ts_array[ti].ground = 1;
ts_array[ti].newterm = makecs(hreg);
new_heap_functor(hreg,get_str_psc(arg));
hreg += get_arity(get_str_psc(arg));
}
}
}
}
printf("intern_term: shouldn't happen\n");
return 0;
}
