/* File: tr_utils.c ** Author(s): Prasad Rao, Juliana Freire, Kostis Sagonas ** Contact: xsb-contact@cs.sunysb.edu ** ** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1998 ** ** XSB is free software; you can redistribute it and/or modify it under the ** terms of the GNU Library General Public License as published by the Free ** Software Foundation; either version 2 of the License, or (at your option) ** any later version. ** ** XSB is distributed in the hope that it will be useful, but WITHOUT ANY ** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS ** FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for ** more details. ** ** You should have received a copy of the GNU Library General Public License ** along with XSB; if not, write to the Free Software Foundation, ** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ** ** $Id: tr_utils.c,v 1.71 2002/10/28 15:28:50 lfcastro Exp $ ** */ #include "xsb_config.h" #include "xsb_debug.h" #include #include /* Special debug includes */ #include "debugs/debug_tries.h" #include "auxlry.h" #include "cell_xsb.h" #include "cinterf.h" #include "binding.h" #include "psc_xsb.h" #include "heap_xsb.h" #include "memory_xsb.h" #include "register.h" #include "deref.h" #include "flags_xsb.h" #include "trie_internals.h" #include "tst_aux.h" #include "cut_xsb.h" #include "macro_xsb.h" #include "sw_envs.h" #include "choice.h" #include "inst_xsb.h" #include "error_xsb.h" #include "io_builtins_xsb.h" #include "trassert.h" #include "tr_utils.h" #include "tst_utils.h" #include "subp.h" #include "debug_xsb.h" /*----------------------------------------------------------------------*/ #define MAX_VAR_SIZE 200 #include "ptoc_tag_xsb_i.h" #include "term_psc_xsb_i.h" /*----------------------------------------------------------------------*/ xsbBool has_unconditional_answers(VariantSF subg) { ALNptr node_ptr = subg_answers(subg); /* Either subgoal has no answers or it is completed */ /* and its answer list has already been reclaimed. */ /* In either case, the result is immediately obtained. */ if (node_ptr <= COND_ANSWERS) return (node_ptr == UNCOND_ANSWERS); /* If the subgoal has not been completed, or is early completed but its */ /* answer list has not been reclaimed yet, check each of its nodes. */ while (node_ptr) { if (is_unconditional_answer(ALN_Answer(node_ptr))) return TRUE; node_ptr = ALN_Next(node_ptr); } return FALSE; } /*----------------------------------------------------------------------*/ /* * Given a subgoal of a variant predicate, returns its subgoal frame * if it has a table entry; returns NULL otherwise. If requested, the * answer template is constructed on the heap as a ret/n term and * passed back via the last argument. */ VariantSF get_variant_sf(Cell callTerm, TIFptr pTIF, Cell *retTerm) { int arity; BTNptr root, leaf; Cell callVars[MAX_VAR_SIZE + 1]; root = TIF_CallTrie(pTIF); if ( IsNULL(root) ) return NULL; arity = get_arity(TIF_PSC(pTIF)); leaf = variant_trie_lookup(root, arity, clref_val(callTerm) + 1, callVars); if ( IsNULL(leaf) ) return NULL; if ( IsNonNULL(retTerm) ) *retTerm = build_ret_term(callVars[0], &callVars[1]); return ( CallTrieLeaf_GetSF(leaf) ); } /*----------------------------------------------------------------------*/ /* * Given a subgoal of a subsumptive predicate, returns the subgoal * frame of some producing table entry which subsumes it; returns NULL * otherwise. The answer template with respect to this producer entry * is constructed on the heap as a ret/n term and passed back via the * last argument. */ SubProdSF get_subsumer_sf(Cell callTerm, TIFptr pTIF, Cell *retTerm) { BTNptr root, leaf; int arity; TriePathType path_type; SubProdSF sf; Cell ansTmplt[MAX_VAR_SIZE + 1]; root = TIF_CallTrie(pTIF); if ( IsNULL(root) ) return NULL; arity = get_arity(TIF_PSC(pTIF)); leaf = subsumptive_trie_lookup(root, arity, clref_val(callTerm) + 1, &path_type, ansTmplt); if ( IsNULL(leaf) ) return NULL; sf = (SubProdSF)CallTrieLeaf_GetSF(leaf); if ( IsProperlySubsumed(sf) ) { sf = conssf_producer(sf); construct_answer_template(callTerm, sf, ansTmplt); } if ( IsNonNULL(retTerm) ) *retTerm = build_ret_term(ansTmplt[0], &ansTmplt[1]); return ( sf ); } /*----------------------------------------------------------------------*/ BTNptr get_trie_root(BTNptr node) { while ( IsNonNULL(node) ) { if ( IsTrieRoot(node) ) return node; node = BTN_Parent(node); } /* * If the trie is constructed correctly, processing will not reach * here, other than if 'node' was originally NULL. */ return NULL; } /*----------------------------------------------------------------------*/ /* * Given a vector of terms and their number, N, builds a ret/N structure * on the heap containing those terms. Returns this constructed term. */ Cell build_ret_term(int arity, Cell termVector[]) { Pair sym; CPtr ret_term; int i, is_new; if ( arity == 0 ) return makestring(get_ret_string()); /* return as a term */ else { ret_term = hreg; /* pointer to where ret(..) will be built */ sym = insert("ret", (byte)arity, (Psc)flags[CURRENT_MODULE], &is_new); new_heap_functor(hreg, pair_psc(sym)); for ( i = 0; i < arity; i++ ) nbldval(termVector[i]); return makecs(ret_term); /* return as a term */ } } /*----------------------------------------------------------------------*/ /* * Create the answer template for a subsumed call with the given producer. * The template is stored in an array supplied by the caller. */ void construct_answer_template(Cell callTerm, SubProdSF producer, Cell templ[]) { Cell subterm, symbol; int sizeAnsTmplt; /* * Store the symbols along the path of the more general call. */ SymbolStack_ResetTOS; SymbolStack_PushPath(subg_leaf_ptr(producer)); /* * Push the arguments of the subsumed call. */ TermStack_ResetTOS; TermStack_PushFunctorArgs(callTerm); /* * Create the answer template while we process. Since we know we have a * more general subsuming call, we can greatly simplify the "matching" * process: we know we either have exact matches of non-variable symbols * or a variable paired with some subterm of the current call. */ sizeAnsTmplt = 0; while ( ! TermStack_IsEmpty ) { TermStack_Pop(subterm); XSB_Deref(subterm); SymbolStack_Pop(symbol); if ( IsTrieVar(symbol) && IsNewTrieVar(symbol) ) templ[++sizeAnsTmplt] = subterm; else if ( IsTrieFunctor(symbol) ) TermStack_PushFunctorArgs(subterm) else if ( IsTrieList(symbol) ) TermStack_PushListArgs(subterm) } templ[0] = sizeAnsTmplt; } /*----------------------------------------------------------------------*/ /* * Given a term representing a tabled call, determine whether it is * recorded in the Call Table. If it is, then return a pointer to its * subgoal frame and construct on the heap the answer template required * to retrieve answers for this call. Place a reference to this term in * the location pointed to by the second argument. */ VariantSF get_call(Cell callTerm, Cell *retTerm) { Psc psc; TIFptr tif; int arity; BTNptr root, leaf; VariantSF sf; Cell callVars[MAX_VAR_SIZE + 1]; psc = term_psc(callTerm); if ( IsNULL(psc) ) { err_handle(TYPE, 1, "get_call", 3, "callable term", callTerm); return NULL; } tif = get_tip(psc); if ( IsNULL(tif) ) xsb_abort("Predicate %s/%d is not tabled", get_name(psc), get_arity(psc)); root = TIF_CallTrie(tif); if ( IsNULL(root) ) return NULL; arity = get_arity(psc); leaf = variant_trie_lookup(root, arity, clref_val(callTerm) + 1, callVars); if ( IsNULL(leaf) ) return NULL; else { sf = CallTrieLeaf_GetSF(leaf); if ( IsProperlySubsumed(sf) ) construct_answer_template(callTerm, conssf_producer(sf), callVars); *retTerm = build_ret_term(callVars[0],&callVars[1]); return sf; } } /*======================================================================*/ /* * D E L E T I N G T R I E S * =========================== */ /* Stack for top-down traversing and freeing components of a trie -------------------------------------------------------------- */ struct freeing_stack_node{ BTNptr item; struct freeing_stack_node *next; }; #define push_node(node){\ struct freeing_stack_node *temp;\ temp = (struct freeing_stack_node *)malloc(sizeof(struct freeing_stack_node));\ if (temp == NULL){\ xsb_exit("Out of Memory");\ } else {\ temp->next = node_stk_top;\ temp->item = node;\ node_stk_top = temp;\ }\ } #define pop_node(node){\ struct freeing_stack_node *temp;\ if (node_stk_top == NULL) {\ xsb_dbgmsg((LOG_DEBUG,"DELETE_PREDICATE_TABLE: pop attempted from NULL"));\ return;\ }\ node = node_stk_top->item;\ temp = node_stk_top;\ node_stk_top = node_stk_top->next;\ free(temp);\ } static void free_trie_ht(BTHTptr ht) { TrieHT_RemoveFromAllocList(*smBTHT,ht); free(BTHT_BucketArray(ht)); SM_DeallocateStruct(*smBTHT,ht); } static void delete_variant_table(BTNptr x) { struct freeing_stack_node *node_stk_top = 0, *call_nodes_top = 0; BTNptr node, rnod, *Bkp; BTHTptr ht; if ( IsNULL(x) ) return; push_node(x); while (node_stk_top != 0) { pop_node(node); if ( IsHashHeader(node) ) { ht = (BTHTptr) node; for (Bkp = BTHT_BucketArray(ht); Bkp < BTHT_BucketArray(ht) + BTHT_NumBuckets(ht); Bkp++) { if ( IsNonNULL(*Bkp) ) push_node(*Bkp); } free_trie_ht(ht); } else { if ( IsNonNULL(BTN_Sibling(node)) ) push_node(BTN_Sibling(node)); if ( IsNonNULL(BTN_Child(node)) ) { if ( IsLeafNode(node) ) { /* * Remove the subgoal frame and its dependent structures */ VariantSF pSF = CallTrieLeaf_GetSF(node); if ( IsNonNULL(subg_ans_root_ptr(pSF)) ) { call_nodes_top = node_stk_top; push_node((BTNptr)subg_ans_root_ptr(pSF)); while (node_stk_top != call_nodes_top) { pop_node(rnod); if ( IsHashHeader(rnod) ) { ht = (BTHTptr) rnod; for (Bkp = BTHT_BucketArray(ht); Bkp < BTHT_BucketArray(ht) + BTHT_NumBuckets(ht); Bkp++) { if ( IsNonNULL(*Bkp) ) push_node(*Bkp); } free_trie_ht(ht); } else { if (BTN_Sibling(rnod)) push_node(BTN_Sibling(rnod)); if ( ! IsLeafNode(rnod) ) push_node(BTN_Child(rnod)); SM_DeallocateStruct(*smBTN,rnod); } } } /* free answer trie */ free_answer_list(pSF); FreeProducerSF(pSF); } /* is leaf */ else push_node(BTN_Child(node)); } /* there is a child of "node" */ SM_DeallocateStruct(*smBTN,node); } } } /*----------------------------------------------------------------------*/ /* Delete the table for a given tabled predicate, specified as a TIF */ /*----------------------------------------------------------------------*/ void delete_predicate_table(TIFptr tif) { if ( IsVariantPredicate(tif) ) delete_variant_table(TIF_CallTrie(tif)); else delete_subsumptive_table(tif); TIF_CallTrie(tif) = NULL; TIF_Subgoals(tif) = NULL; } /*----------------------------------------------------------------------*/ static int is_hash(BTNptr x) { if( x == NULL) return(0); else return( IsHashHeader(x) ); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* * Set values for "parent" -- the parent node of "current" -- and * "cur_hook" -- an address containing a pointer into "current"'s level * in the trie. If there is no parent node, use the value of * "root_hook" to find the level. If the hook is actually contained in * the parent of current (as its child field), then we've ascended as * far as we need to go. Set parent to NULL to indicate this. */ static void set_parent_and_node_hook(BTNptr current, BTNptr *root_hook, BTNptr *parent, BTNptr **cur_hook) { BTNptr par; if ( IsTrieRoot(current) ) /* defend against root having a set parent field */ par = NULL; else { par = BTN_Parent(current); if ( IsNonNULL(par) && (root_hook == &BTN_Child(par)) ) par = NULL; /* stop ascent when hooking node is reached */ } if ( IsNULL(par) ) *cur_hook = root_hook; else *cur_hook = &BTN_Child(par); *parent = par; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* * Given some non-root node which is *not the first* (or only) sibling, * find the node which precedes it in the chain. Should ONLY be used * when deleting trie components. If a hash table is encountered, then * its number of contents is decremented. */ static BTNptr get_prev_sibl(BTNptr node) { BTNptr sibling_chain; sibling_chain = BTN_Child(BTN_Parent(node)); if ( IsHashHeader(sibling_chain) ) { BTHTptr ht = (BTHTptr)sibling_chain; BTHT_NumContents(ht)--; sibling_chain = *CalculateBucketForSymbol(ht,BTN_Symbol(node)); } while(sibling_chain != NULL){ if (BTN_Sibling(sibling_chain) == node) return(sibling_chain); sibling_chain = BTN_Sibling(sibling_chain); } xsb_abort("Error in get_previous_sibling"); return(NULL); } /*----------------------------------------------------------------------*/ /* deletes and reclaims a whole branch in the return trie */ /*----------------------------------------------------------------------*/ /* * Delete a branch in the trie down from node `lowest_node_in_branch' * up to the level pointed to by the hook location, as pointed to by * `hook'. Under normal use, the "hook" is either for the root of the * trie, or for the first level of the trie (is a pointer to the child * field of the root). */ void delete_branch(BTNptr lowest_node_in_branch, BTNptr *hook) { int num_left_in_hash; BTNptr prev, parent_ptr, *y1, *z; while ( IsNonNULL(lowest_node_in_branch) && ( Contains_NOCP_Instr(lowest_node_in_branch) || IsTrieRoot(lowest_node_in_branch) ) ) { /* * Walk up a path with no branches, i.e., the nodes along this path * have no siblings. We know this because the instruction in the * node is of the no_cp variety. */ set_parent_and_node_hook(lowest_node_in_branch,hook,&parent_ptr,&y1); if (is_hash(*y1)) { z = CalculateBucketForSymbol((BTHTptr)(*y1), BTN_Symbol(lowest_node_in_branch)); if ( *z != lowest_node_in_branch ) xsb_dbgmsg((LOG_DEBUG,"DELETE_BRANCH: trie node not found in hash table")); *z = NULL; num_left_in_hash = --BTHT_NumContents((BTHTptr)*y1); if (num_left_in_hash > 0) { /* * `lowest_node_in_branch' has siblings, even though they are not in * the same chain. Therefore we cannot delete the parent, and so * we're done. */ SM_DeallocateStruct(*smBTN,lowest_node_in_branch); return; } else free_trie_ht((BTHTptr)(*y1)); } /* * Remove this node and continue. */ SM_DeallocateStruct(*smBTN,lowest_node_in_branch); lowest_node_in_branch = parent_ptr; } if (lowest_node_in_branch == NULL) *hook = 0; else { if (Contains_TRY_Instr(lowest_node_in_branch)) { /* Alter sibling's instruction: trust -> no_cp retry -> try */ BTN_Instr(BTN_Sibling(lowest_node_in_branch)) = BTN_Instr(BTN_Sibling(lowest_node_in_branch)) -1; y1 = &BTN_Child(BTN_Parent(lowest_node_in_branch)); if (is_hash(*y1)) { z = CalculateBucketForSymbol((BTHTptr)(*y1), BTN_Symbol(lowest_node_in_branch)); num_left_in_hash = --BTHT_NumContents((BTHTptr)*y1); } else z = y1; *z = BTN_Sibling(lowest_node_in_branch); } else { /* not the first in the sibling chain */ prev = get_prev_sibl(lowest_node_in_branch); BTN_Sibling(prev) = BTN_Sibling(lowest_node_in_branch); if (Contains_TRUST_Instr(lowest_node_in_branch)) BTN_Instr(prev) -= 2; /* retry -> trust ; try -> nocp */ } SM_DeallocateStruct(*smBTN,lowest_node_in_branch); } } /*----------------------------------------------------------------------*/ void safe_delete_branch(BTNptr lowest_node_in_branch) { byte choicepttype; MakeStatusDeleted(lowest_node_in_branch); choicepttype = 0x3 & BTN_Instr(lowest_node_in_branch); BTN_Instr(lowest_node_in_branch) = choicepttype | trie_no_cp_fail; } void undelete_branch(BTNptr lowest_node_in_branch) { byte choicepttype; byte typeofinstr; if( IsDeletedNode(lowest_node_in_branch) ){ choicepttype = 0x3 & BTN_Instr(lowest_node_in_branch); /* Status contains the original instruction that was in that trie node. here we extract the original instruction and the next statement makes it into the instruction associated with that node. */ typeofinstr = (~0x3) & BTN_Status(lowest_node_in_branch); BTN_Instr(lowest_node_in_branch) = choicepttype | typeofinstr; /* This only sets the status field. It is also necessary to set the instruction field correctly, which is done above. */ MakeStatusValid(lowest_node_in_branch); } else /* This is permitted, because we might bt_delete, then insert (non-backtrackably) and then backtrack. */ xsb_dbgmsg((LOG_INTERN, "Undeleting a node that is not deleted")); } /*----------------------------------------------------------------------*/ #define DELETE_TRIE_STACK_INIT 100 #define MAX_DELETE_TRIE_STACK_SIZE 1000 #define DT_NODE 0 #define DT_DS 1 #define DT_HT 2 char *delete_trie_op = NULL; BTNptr *delete_trie_node = NULL; BTHTptr *delete_trie_hh = NULL; int trie_op_size, trie_node_size, trie_hh_size; #define push_delete_trie_node(node,op) {\ trie_op_top++;\ if (trie_op_top >= trie_op_size) {\ trie_op_size = 2*trie_op_size;\ delete_trie_op = (char *)realloc(delete_trie_op,trie_op_size*sizeof(char));\ if (!delete_trie_op) xsb_exit("out of space for deleting trie");\ /*xsb_dbgmsg((LOG_DEBUG,"realloc delete_trie_op to %d",trie_op_size));*/\ }\ delete_trie_op[trie_op_top] = op;\ trie_node_top++;\ if (trie_node_top >= trie_node_size) {\ trie_node_size = 2*trie_node_size;\ delete_trie_node = (BTNptr *)realloc(delete_trie_node,trie_node_size*sizeof(BTNptr));\ if (!delete_trie_node) xsb_exit("out of space for deleting trie");\ /*xsb_dbgmsg((LOG_DEBUG,"realloc delete_trie_node to %d",trie_node_size));*/\ }\ delete_trie_node[trie_node_top] = node;\ } #define push_delete_trie_hh(hh) {\ trie_op_top++;\ if (trie_op_top >= trie_op_size) {\ trie_op_size = 2*trie_op_size;\ delete_trie_op = (char *)realloc(delete_trie_op,trie_op_size*sizeof(char));\ if (!delete_trie_op) xsb_exit("out of space for deleting trie");\ /*xsb_dbgmsg((LOG_DEBUG,"realloc delete_trie_op to %d",trie_op_size));*/\ }\ delete_trie_op[trie_op_top] = DT_HT;\ trie_hh_top++;\ if (trie_hh_top >= trie_hh_size) {\ trie_hh_size = 2*trie_hh_size;\ delete_trie_hh = (BTHTptr *)realloc(delete_trie_hh,trie_hh_size*sizeof(BTHTptr));\ if (!delete_trie_hh) xsb_exit("out of space for deleting trie");\ /*xsb_dbgmsg((LOG_DEBUG,"realloc delete_trie_hh to %d",trie_hh_size));*/\ }\ delete_trie_hh[trie_hh_top] = hh;\ } void delete_trie(BTNptr iroot) { BTNptr root, sib, chil; int trie_op_top = 0; int trie_node_top = 0; int trie_hh_top = -1; if (!delete_trie_op) { delete_trie_op = (char *)malloc(DELETE_TRIE_STACK_INIT*sizeof(char)); delete_trie_node = (BTNptr *)malloc(DELETE_TRIE_STACK_INIT*sizeof(BTNptr)); delete_trie_hh = (BTHTptr *)malloc(DELETE_TRIE_STACK_INIT*sizeof(BTHTptr)); trie_op_size = trie_node_size = trie_hh_size = DELETE_TRIE_STACK_INIT; } delete_trie_op[0] = 0; delete_trie_node[0] = iroot; while (trie_op_top >= 0) { /* xsb_dbgmsg((LOG_DEBUG,"top %d %d %d %p",trie_op_top,trie_hh_top, delete_trie_op[trie_op_top],delete_trie_node[trie_node_top])); */ switch (delete_trie_op[trie_op_top--]) { case DT_DS: root = delete_trie_node[trie_node_top--]; SM_DeallocateStruct(*smBTN,root); break; case DT_HT: free_trie_ht(delete_trie_hh[trie_hh_top--]); break; case DT_NODE: root = delete_trie_node[trie_node_top--]; if ( IsNonNULL(root) ) { if ( IsHashHeader(root) ) { BTHTptr hhdr; BTNptr *base, *cur; hhdr = (BTHTptr)root; base = BTHT_BucketArray(hhdr); push_delete_trie_hh(hhdr); for ( cur = base; cur < base + BTHT_NumBuckets(hhdr); cur++ ) { if (IsNonNULL(*cur)) { push_delete_trie_node(*cur,DT_NODE); } } } else { sib = BTN_Sibling(root); chil = BTN_Child(root); /* Child nodes == NULL is not the correct test*/ if (IsLeafNode(root)) { if (IsNonNULL(chil)) xsb_exit("Anomaly in delete_trie !"); push_delete_trie_node(root,DT_DS); if (IsNonNULL(sib)) { push_delete_trie_node(sib,DT_NODE); } } else { push_delete_trie_node(root,DT_DS); if (IsNonNULL(sib)) { push_delete_trie_node(sib,DT_NODE); } if (IsNonNULL(chil)) { push_delete_trie_node(chil,DT_NODE); } } } } else printf("null node"); break; } } if (trie_op_size > MAX_DELETE_TRIE_STACK_SIZE) { free(delete_trie_op); delete_trie_op = NULL; free(delete_trie_node); delete_trie_node = NULL; free(delete_trie_hh); delete_trie_hh = NULL; trie_op_size = 0; } } /*======================================================================*/ /* * A N S W E R O P E R A T I O N S * ================================= */ /*----------------------------------------------------------------------*/ /* * This does not reclaim space for deleted nodes, only marks * the node as deleted and changes the try instruction to fail. * The deleted node is then linked into the del_nodes_list * in the completion stack. */ void delete_return(BTNptr l, VariantSF sg_frame) { ALNptr a, n, next; NLChoice c; int groundcall = FALSE; #ifdef LOCAL_EVAL TChoice tc; #endif xsb_dbgmsg((LOG_INTERN, "DELETE_NODE: %d - Par: %d", l, BTN_Parent(l))); /* deleting an answer makes it false, so we have to deal with delay lists */ if (is_conditional_answer(l)) { ASI asi = Delay(l); release_all_dls(asi); /* TLS 12/00 changed following line from (l == subg_ans_root_ptr(sg_frame) && .. so that negation failure simplification is properly performed */ if (l == BTN_Child(subg_ans_root_ptr(sg_frame)) && IsEscapeNode(l)) groundcall=TRUE; /* do it here, when l is still valid */ } if (is_completed(sg_frame)) { safe_delete_branch(l); } else { delete_branch(l,&subg_ans_root_ptr(sg_frame)); n = subg_ans_list_ptr(sg_frame); /* Find previous sibling -pvr */ while (ALN_Answer(ALN_Next(n)) != l) { n = ALN_Next(n);/* if a is not in that list a core dump will result */ } if (n == NULL) { xsb_exit("Error in delete_return()"); } a = ALN_Next(n); next = ALN_Next(a); ALN_Answer(a) = NULL; /* since we eagerly release trie nodes, this is necessary to keep garbage collection sane */ ALN_Next(a) = compl_del_ret_list(subg_compl_stack_ptr(sg_frame)); compl_del_ret_list(subg_compl_stack_ptr(sg_frame)) = a; ALN_Next(n) = next; /* Make consumed answer field of consumers point to previous sibling if they point to a deleted answer */ c = (NLChoice) subg_asf_list_ptr(sg_frame); while(c != NULL){ if(nlcp_trie_return(c) == a){ nlcp_trie_return(c) = n; } c = (NLChoice)nlcp_prevlookup(c); } #if (defined(LOCAL_EVAL)) /* if gen-cons points to deleted answer, make it * point to previous sibling */ tc = (TChoice)subg_cp_ptr(sg_frame); if (tcp_trie_return(tc) == a) { tcp_trie_return(tc) = n; } #endif ALN_Next(n) = next; if(next == NULL){ /* last answer */ subg_ans_list_tail(sg_frame) = n; } } if (is_conditional_answer(l)) { simplify_pos_unsupported(l); if (groundcall) { mark_subgoal_failed(sg_frame); simplify_neg_fails(sg_frame); } } } /*----------------------------------------------------------------------*/ /* Given a tabled subgoal, go through its list of deleted nodes (in the * completion stack), and reclaim the leaves and corresponding branches *----------------------------------------------------------------------*/ void reclaim_del_ret_list(VariantSF sg_frame) { ALNptr x,y; x = compl_del_ret_list(subg_compl_stack_ptr(sg_frame)); while (x != NULL) { y = x; x = ALN_Next(x); /* delete_branch(ALN_Answer(y), &subg_ans_root_ptr(sg_frame)); */ SM_DeallocateStruct(smALN,y); } } /*----------------------------------------------------------------------*/ /* ** Used in aggregs.P to implement aggregates. ** Takes: breg (the place where choice point is saved) and arity. ** Returns: subgoal skeleton (i.e., ret(X,Y,Z), where X,Y,Z are all the ** distinct variables in the subgoal); ** Pointer to the subgoal. */ void breg_retskel(void) { Pair sym; Cell term; VariantSF sg_frame; CPtr tcp, cptr, where; int is_new, i; Integer breg_offset, Nvars; breg_offset = ptoc_int(1); tcp = (CPtr)((Integer)(tcpstack.high) - breg_offset); sg_frame = (VariantSF)(tcp_subgoal_ptr(tcp)); where = tcp_template(tcp); Nvars = int_val(cell(where)) & 0xffff; cptr = where - Nvars - 1; if (Nvars == 0) { ctop_string(3, get_ret_string()); } else { bind_cs((CPtr)ptoc_tag(3), hreg); sym = insert("ret", (byte)Nvars, (Psc)flags[CURRENT_MODULE], &is_new); new_heap_functor(hreg, sym->psc_ptr); for (i = Nvars; i > 0; i--) { term = (Cell)(*(CPtr)(cptr+i)); nbldval(term); } } ctop_int(4, (Integer)sg_frame); } /*======================================================================*/ /* * I N T E R N E D T R I E S * =========================== */ #define ADJUST_SIZE 100 BTNptr *Set_ArrayPtr = NULL; /* * first_free_set is the index of the first deleted set. The deleted * tries are deleted in builtin DELETE_TRIE, and the corresponding * elements in Set_ArrayPtr are linked to form a list. So * Set_ArrayPtr[first_free_set] contains the index of the next deleted * set, ..., the last one contains 0. If first_free_set == 0, that * means no free set available. */ static int first_free_set = 0; static int Set_ArraySz = 100; /* * num_sets is the number of sets have been used (including the fixed * trie, Set_ArrayPtr[0] (see trie_intern/3)). It is also the index for * the next element to use when no free element is available. */ static int num_sets = 1; /*----------------------------------------------------------------------*/ /* Allocate an array of handles to interned tries. */ void init_newtrie(void) { Set_ArrayPtr = (BTNptr *) calloc(Set_ArraySz,sizeof(BTNptr)); } /*----------------------------------------------------------------------*/ /* Returns a handle to an unused interned trie. */ Integer newtrie(void) { int i; Integer result; if (first_free_set != 0) { /* a free set is available */ i = first_free_set; /* save it in i */ result = (Integer)first_free_set; first_free_set = (long) Set_ArrayPtr[first_free_set] >> 2; Set_ArrayPtr[i] = NULL; /* must be reset to NULL */ } else { if (num_sets == Set_ArraySz) { /* run out of elements */ BTNptr *temp_arrayptr; temp_arrayptr = Set_ArrayPtr; Set_ArraySz += ADJUST_SIZE; /* adjust the array size */ Set_ArrayPtr = (BTNptr *) calloc(Set_ArraySz ,sizeof(BTNptr)); if (Set_ArrayPtr == NULL) xsb_exit("Out of memory in new_trie/1"); for (i = 0; i < num_sets; i++) Set_ArrayPtr[i] = temp_arrayptr[i]; free(temp_arrayptr); } result = (Integer)num_sets; num_sets++; } return result; } /*----------------------------------------------------------------------*/ void trie_intern(void) { prolog_term term; int RootIndex; int flag; BTNptr Leaf; term = ptoc_tag(1); RootIndex = ptoc_int(2); xsb_dbgmsg((LOG_INTERN, "Interning ")); dbg_printterm(LOG_INTERN,stddbg,term,25); xsb_dbgmsg((LOG_INTERN, "In trie with root %d", RootIndex)); switch_to_trie_assert; Leaf = whole_term_chk_ins(term,&(Set_ArrayPtr[RootIndex]),&flag); switch_from_trie_assert; ctop_int(3,(Integer)Leaf); ctop_int(4,flag); xsb_dbgmsg((LOG_INTERN, "Exit flag %d",flag)); } /*----------------------------------------------------------------------*/ int trie_interned(void) { int RootIndex; int ret_val = FALSE; Cell Leafterm, trie_term; trie_term = ptoc_tag(1); RootIndex = ptoc_int(2); Leafterm = ptoc_tag(3); /* * Only if Set_ArrayPtr[RootIndex] is a valid BTNptr can we run this * builtin. That means Set_ArrayPtr[RootIndex] can neither be NULL, * nor a deleted set (deleted by builtin delete_trie/1). */ if ((Set_ArrayPtr[RootIndex] != NULL) && (!((long) Set_ArrayPtr[RootIndex] & 0x3))) { XSB_Deref(trie_term); XSB_Deref(Leafterm); if (isref(Leafterm)) { reg_arrayptr = reg_array -1; num_vars_in_var_regs = -1; pushreg(trie_term); pcreg = (byte *)Set_ArrayPtr[RootIndex]; ret_val = TRUE; } else{ xsb_exit("Not yet grd Leafterm!"); } } return(ret_val); } /*----------------------------------------------------------------------*/ /* * This is builtin #162: TRIE_DISPOSE(+ROOT, +LEAF), to dispose a branch * of the trie rooted at Set_ArrayPtr[ROOT]. */ void trie_dispose(void) { BTNptr Leaf; long Rootidx; Rootidx = ptoc_int(1); Leaf = (BTNptr)ptoc_int(2); switch_to_trie_assert; delete_branch(Leaf, &(Set_ArrayPtr[Rootidx])); switch_from_trie_assert; } /*----------------------------------------------------------------------*/ #define DELETED_SET 1 void delete_interned_trie(int tmpval) { /* * We can only delete a valid BTNptr, so that only those sets * that were used before can be put into the free set list. */ if ((Set_ArrayPtr[tmpval] != NULL) && (!((long) Set_ArrayPtr[tmpval] & 0x3))) { switch_to_trie_assert; delete_trie(Set_ArrayPtr[tmpval]); switch_from_trie_assert; /* * Save the value of first_free_set into Set_ArrayPtr[tmpval]. * Some simple encoding is needed, because in trie_interned/4 we * have to know this set is already deleted. */ Set_ArrayPtr[tmpval] = (BTNptr) (first_free_set << 2 | DELETED_SET); first_free_set = tmpval; } } /* Changes made by Prasad Rao. Jun 20th 2000 The solution for reclaiming the garbage nodes resulting from trie dispose is as follows. Maintain a datastructure as follows 1) IGRhead -> Root1 -> Root2 -> Root3 -> null | | | | | | v v v Leaf11 Leaf21 Leaf31 | | | | | | V v v Leaf12 null Leaf32 | | v | null v Leaf33 | v null To reclaim all the garbage associated with a particular root a) remove the root from the root list b) remove all the garbage branches assoc with the root by calling delete_branch(leaf,....) Done!! */ static IGRptr IGRhead = NULL; static IGRptr newIGR(long root) { IGRptr igr; igr = malloc(sizeof(InternGarbageRoot)); igr -> root = root; igr -> leaves = NULL; igr -> next = NULL; return igr; } static IGLptr newIGL(BTNptr leafn) { IGLptr igl; igl = malloc(sizeof(InternGarbageLeaf)); igl -> leaf = leafn; igl -> next = NULL; return igl; } static IGRptr getIGRnode(long rootn) { IGRptr p = IGRhead; while(p != NULL){ if(p -> root == rootn) return p; else p = p -> next; } if(p != NULL) xsb_warn("Invariant p == NULL violated"); p = newIGR(rootn); p -> next = IGRhead; IGRhead = p; return p; } static IGRptr getAndRemoveIGRnode(long rootn) { IGRptr p = IGRhead; if(p == NULL) return NULL; else if(p -> root == rootn){ IGRhead = p -> next; return p; } else{ IGRptr q = p; p = p -> next; while(p != NULL){ if(p -> root == rootn){ q -> next = p -> next; return p; } else{ q = p; p = p -> next; } } } xsb_dbgmsg((LOG_INTERN, "Root node not found in Garbage List")); return NULL; } /* * Insert "leafn" into the garbage list, "r". * This is done when leafn is deleted so that we could undelete it or later * garbage-collect it. */ static void insertLeaf(IGRptr r, BTNptr leafn) { /* Just make sure that the leaf is not already there */ IGLptr p; if(r == NULL) return; p = r -> leaves; while(p != NULL){ /* xsb_warn("loopd"); */ if(p -> leaf == leafn){ /* The following should be permitted, because we should be able to backtrackably delete backtrackably deleted nodes (which should have no effect) */ if (IsDeletedNode(leafn)) xsb_dbgmsg((LOG_INTERN, "The leaf node being deleted has already been deleted")); return; } p = p -> next; } p = newIGL(leafn); p -> next = r -> leaves; r -> leaves = p; } /* * This is builtin : TRIE_DISPOSE_NR(+ROOT, +LEAF), to * mark for disposal a branch * of the trie rooted at Set_ArrayPtr[ROOT]. */ void trie_dispose_nr(void) { BTNptr Leaf; long Rootidx; Rootidx = ptoc_int(1); Leaf = (BTNptr)ptoc_int(2); switch_to_trie_assert; insertLeaf(getIGRnode(Rootidx), Leaf); safe_delete_branch(Leaf); switch_from_trie_assert; } void reclaim_uninterned_nr(long rootidx) { IGRptr r = getAndRemoveIGRnode(rootidx); IGLptr l, p; BTNptr leaf; if (r!=NULL) l = r-> leaves; else return; free(r); while(l != NULL){ /* printf("Loop b %p\n", l); */ leaf = l -> leaf; p = l -> next; free(l); switch_to_trie_assert; if(IsDeletedNode(leaf)) { delete_branch(leaf, &(Set_ArrayPtr[rootidx])); } else { /* This is allowed: If we backtrack over a delete, the node that was marked for deletion and placed in the garbage list is unmarked, but isn't removed from the garbage list. So it is a non-deleted node on the garbage list. It is removed from there only when we reclaim space. */ xsb_dbgmsg((LOG_INTERN,"Non deleted interned node in garbage list - ok")); } switch_from_trie_assert; l = p; } } /*----------------------------------------------------------------------*/ void trie_undispose(long rootIdx, BTNptr leafn) { IGRptr r = getIGRnode(rootIdx); IGLptr p = r -> leaves; if(p == NULL){ xsb_dbgmsg((LOG_INTERN, "In trie_undispose: The node being undisposed has been previously deleted")); } else{ if(p -> leaf == leafn){ r -> leaves = p -> next; free(p); if(r -> leaves == NULL){ /* Do not want roots with no leaves hanging around */ getAndRemoveIGRnode(rootIdx); } } undelete_branch(leafn); } }