From 1f4108b0afbc7711f0313159a7822212dfd437b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 20 Oct 2011 22:25:07 +0100 Subject: [PATCH 01/40] fix bad init of prompt. --- os/pl-file.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/os/pl-file.c b/os/pl-file.c index 20afd54eb..300211c3d 100644 --- a/os/pl-file.c +++ b/os/pl-file.c @@ -328,16 +328,6 @@ initIO() const atom_t *np; int i; -#ifdef __YAP_PROLOG__ - volatile IOFUNCTIONS buf; - buf = *Sinput->functions; - memset(GD, 0, sizeof(gds_t)); - memset(LD, 0, sizeof(PL_local_data_t)); - GD->os.iofunctions = buf; - Sinput->functions = &GD->os.iofunctions; - Soutput->functions = &GD->os.iofunctions; - Serror->functions = &GD->os.iofunctions; -#endif streamAliases = newHTable(16); streamContext = newHTable(16); PL_register_blob_type(&stream_blob); From 48bfaa1ce1900d50a4d5735c7d742a835d206fa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Sat, 22 Oct 2011 10:25:04 +0100 Subject: [PATCH 02/40] move to 6.3.1 --- H/Yap.h | 2 +- Makefile.in | 2 +- misc/Yap.spec | 2 +- misc/Yap64.spec | 2 +- misc/yap.nsi | 2 +- misc/yap64.nsi | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/H/Yap.h b/H/Yap.h index c13bed032..402948b8b 100644 --- a/H/Yap.h +++ b/H/Yap.h @@ -87,7 +87,7 @@ #undef USE_THREADED_CODE #endif /* USE_THREADED_CODE */ #define inline __inline -#define YAP_VERSION "YAP-6.3.0" +#define YAP_VERSION "YAP-6.3.1" #define BIN_DIR "c:\\Yap\\bin" #define LIB_DIR "c:\\Yap\\lib\\Yap" #define SHARE_DIR "c:\\Yap\\share\\Yap" diff --git a/Makefile.in b/Makefile.in index 6f018f7fc..cda4d200e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -101,7 +101,7 @@ SONAMEFLAG=@SONAMEFLAG@ #4.1VPATH=@srcdir@:@srcdir@/OPTYap CWD=$(PWD) # -VERSION=6.3.0 +VERSION=6.3.1 MYDDAS_VERSION=MYDDAS-0.9.1 # diff --git a/misc/Yap.spec b/misc/Yap.spec index f211aaf41..1a1991398 100644 --- a/misc/Yap.spec +++ b/misc/Yap.spec @@ -3,7 +3,7 @@ Name: yap Summary: Prolog Compiler -Version: 6.3.0 +Version: 6.3.1 Packager: Vitor Santos Costa Release: 1 Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz diff --git a/misc/Yap64.spec b/misc/Yap64.spec index 89607093a..88c4328ac 100644 --- a/misc/Yap64.spec +++ b/misc/Yap64.spec @@ -3,7 +3,7 @@ Name: yap Summary: Prolog Compiler -Version: 6.3.0 +Version: 6.3.1 Packager: Vitor Santos Costa Release: 1 Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz diff --git a/misc/yap.nsi b/misc/yap.nsi index 7ef34eca5..6d1ba6428 100644 --- a/misc/yap.nsi +++ b/misc/yap.nsi @@ -273,4 +273,4 @@ Function .onInstFailed installer, please contact yap-users@sf.net" FunctionEnd -outfile "yap-6.3.0-installer.exe" +outfile "yap-6.3.1-installer.exe" diff --git a/misc/yap64.nsi b/misc/yap64.nsi index 6a74dc639..5efb402e8 100755 --- a/misc/yap64.nsi +++ b/misc/yap64.nsi @@ -270,4 +270,4 @@ Function .onInstFailed installer, please contact yap-users@sf.net" FunctionEnd -outfile "yap64-6.3.0-installer.exe" +outfile "yap64-6.3.1-installer.exe" From 22b0bcac1489731568a436f3469454fe44aa37f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Sat, 22 Oct 2011 16:49:13 +0100 Subject: [PATCH 03/40] mode directed tabling. --- OPTYap/opt.config.h | 2 +- OPTYap/opt.preds.c | 142 ++++++++++++++++++ OPTYap/tab.insts.i | 56 +++++++- OPTYap/tab.macros.h | 85 +++++++++++ OPTYap/tab.structs.h | 56 +++++++- OPTYap/tab.tries.c | 335 ++++++++++++++++++++++++++++++++++++++++++- OPTYap/tab.tries.i | 6 +- pl/tabling.yap | 13 +- 8 files changed, 675 insertions(+), 20 deletions(-) diff --git a/OPTYap/opt.config.h b/OPTYap/opt.config.h index fc5ef710d..ac530ad52 100644 --- a/OPTYap/opt.config.h +++ b/OPTYap/opt.config.h @@ -16,7 +16,7 @@ /************************************************************************ ** General Configuration Parameters ** ************************************************************************/ - +#define MODE_DIRECTED_TABLING /****************************************************************************************** ** use shared pages memory alloc scheme for OPTYap data structures? (optional) ** ******************************************************************************************/ diff --git a/OPTYap/opt.preds.c b/OPTYap/opt.preds.c index 0e49cf70c..66221c676 100644 --- a/OPTYap/opt.preds.c +++ b/OPTYap/opt.preds.c @@ -39,6 +39,9 @@ static Int p_wake_choice_point( USES_REGS1 ); static Int p_abolish_frozen_choice_points_until( USES_REGS1 ); static Int p_abolish_frozen_choice_points_all( USES_REGS1 ); static Int p_table( USES_REGS1 ); +#ifdef MODE_DIRECTED_TABLING +static Int p_table_mode_directed( USES_REGS1 ); +#endif /*MODE_DIRECTED_TABLING*/ static Int p_tabling_mode( USES_REGS1 ); static Int p_abolish_table( USES_REGS1 ); static Int p_abolish_all_tables( USES_REGS1 ); @@ -122,6 +125,9 @@ void Yap_init_optyap_preds(void) { Yap_InitCPred("abolish_frozen_choice_points", 1, p_abolish_frozen_choice_points_until, SafePredFlag|SyncPredFlag); Yap_InitCPred("abolish_frozen_choice_points", 0, p_abolish_frozen_choice_points_all, SafePredFlag|SyncPredFlag); Yap_InitCPred("$c_table", 2, p_table, SafePredFlag|SyncPredFlag|HiddenPredFlag); +#ifdef MODE_DIRECTED_TABLING + Yap_InitCPred("$c_table_mode_directed", 3, p_table_mode_directed, SafePredFlag|SyncPredFlag|HiddenPredFlag); +#endif /*MODE_DIRECTED_TABLING*/ Yap_InitCPred("$c_tabling_mode", 3, p_tabling_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$c_abolish_table", 2, p_abolish_table, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("abolish_all_tables", 0, p_abolish_all_tables, SafePredFlag|SyncPredFlag); @@ -221,11 +227,147 @@ static Int p_table( USES_REGS1 ) { if (pe->cs.p_code.FirstClause) return (FALSE); /* predicate already compiled */ pe->PredFlags |= TabledPredFlag; +#ifdef MODE_DIRECTED_TABLING + new_table_entry(tab_ent, pe, at, arity, NULL); +#else new_table_entry(tab_ent, pe, at, arity); +#endif /*MODE_DIRECTED_TABLING*/ pe->TableOfPred = tab_ent; return (TRUE); } +#ifdef MODE_DIRECTED_TABLING + +static Int p_table_mode_directed( USES_REGS1 ) { + + + Term mod, t, list; + PredEntry *pe; + Atom at; + int arity; + tab_ent_ptr tab_ent; + + mod = Deref(ARG1); + t = Deref(ARG2); + list = ARG3; + + Functor f = FunctorOfTerm(t); + arity=ArityOfFunctor(f); + + int* aux; + int* vec; + + + int i=0,n_index=0,n_agreg=0,n_nindex=0,n_all=0,n_last=0; + + + ALLOC_BLOCK(vec,arity*sizeof(int),int); + ALLOC_BLOCK(aux,arity*sizeof(int),int); + + while(IsPairTerm(list)){ + char *str_val = &RepAtom(AtomOfTerm(HeadOfTerm(list)))->StrOfAE; + //printf("----2 %s %d\n",str_val,i); + if(! strcmp(str_val ,"index")){ + vec[i] = MODE_DIRECTED_INDEX; + n_index++; + } + else if (! strcmp(str_val ,"all")){ + vec[i] = MODE_DIRECTED_ALL; + n_all++; + } + else if(!strcmp(str_val,"last")){ + vec[i] = MODE_DIRECTED_LAST; + n_last++; + } + else if(!strcmp(str_val,"min")){ + vec[i] = MODE_DIRECTED_MIN; + n_agreg++; + } + else if(!strcmp(str_val,"max")){ + vec[i] = MODE_DIRECTED_MAX; + n_agreg++; + } + else if(!strcmp(str_val,"first")){ + vec[i] = MODE_DIRECTED_NINDEX; + } + list=TailOfTerm(list); + i++; + } + + n_nindex = n_index + n_agreg + n_all + n_last; + n_last = n_index + n_agreg + n_all; + n_all = n_index + n_agreg; + n_agreg = n_index; + n_index = 0; + + + + for(i = 0;i < arity; i++){ + if(vec[i]==MODE_DIRECTED_MAX){ + aux[n_agreg]= i << MODE_DIRECTED_TAGBITS; + aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MAX; + n_agreg++; + } + else if(vec[i]==MODE_DIRECTED_MIN){ + aux[n_agreg]= i << MODE_DIRECTED_TAGBITS; + aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MIN; + n_agreg++; + } + + else if(vec[i]==MODE_DIRECTED_INDEX){ + aux[n_index]= i << MODE_DIRECTED_TAGBITS; + aux[n_index]= aux[n_index] + MODE_DIRECTED_INDEX; + n_index++; + } + + else if(vec[i]==MODE_DIRECTED_NINDEX){ + aux[n_nindex]= i << MODE_DIRECTED_TAGBITS; + aux[n_nindex]= aux[n_nindex] + MODE_DIRECTED_NINDEX; + n_nindex++; + } + else if(vec[i]==MODE_DIRECTED_ALL){ + aux[n_all]= i << MODE_DIRECTED_TAGBITS; + aux[n_all]= aux[n_all] + MODE_DIRECTED_ALL; + n_all++; + } + else if(vec[i]==MODE_DIRECTED_LAST){ + aux[n_last]= i << MODE_DIRECTED_TAGBITS; + aux[n_last]= aux[n_last] + MODE_DIRECTED_LAST; + n_last++; + } + } + +/* +i=0; + while(i < arity){ + printf("aux[%d] %p \n",i,aux[i]); + i ++; + } +*/ + + + if (IsAtomTerm(t)) { + at = AtomOfTerm(t); + pe = RepPredProp(PredPropByAtom(at, mod)); + arity = 0; + } else if (IsApplTerm(t)) { + at = NameOfFunctor(FunctorOfTerm(t)); + pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod)); + arity = ArityOfFunctor(FunctorOfTerm(t)); + } else + return (FALSE); + if (pe->PredFlags & TabledPredFlag) + return (TRUE); /* predicate already tabled */ + if (pe->cs.p_code.FirstClause) + return (FALSE); /* predicate already compiled */ + pe->PredFlags |= TabledPredFlag; + new_table_entry(tab_ent, pe, at, arity, aux); + pe->TableOfPred = tab_ent; + return (TRUE); + +} + +#endif /*MODE_DIRECTED_TABLING*/ static Int p_tabling_mode( USES_REGS1 ) { Term mod, t, tvalue; diff --git a/OPTYap/tab.insts.i b/OPTYap/tab.insts.i index 5a5d89820..145e773e4 100644 --- a/OPTYap/tab.insts.i +++ b/OPTYap/tab.insts.i @@ -869,6 +869,10 @@ LOCK(SgFr_lock(sg_fr)); #endif /* TABLE_LOCK_LEVEL */ ans_node = answer_search(sg_fr, subs_ptr); +#ifdef MODE_DIRECTED_TABLING + if(ans_node == NULL) + goto fail; +#endif /*MODE_DIRECTED_TABLING*/ #if defined(TABLE_LOCK_AT_NODE_LEVEL) LOCK(TrNode_lock(ans_node)); #elif defined(TABLE_LOCK_AT_WRITE_LEVEL) @@ -1103,9 +1107,19 @@ dep_fr = CONS_CP(B)->cp_dep_fr; LOCK(DepFr_lock(dep_fr)); ans_node = DepFr_last_answer(dep_fr); +#ifdef MODE_DIRECTED_TABLING + ans_node_ptr aux_ans_node = ans_node; + do { + ans_node=TrNode_child(ans_node); + } while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node)); + if (ans_node){ + TrNode_child(aux_ans_node)=ans_node; +#else if (TrNode_child(ans_node)) { /* unconsumed answer */ ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#endif /*MODE_DIRECTED_TABLING*/ + DepFr_last_answer(dep_fr) = ans_node; UNLOCK(DepFr_lock(dep_fr)); consume_answer_and_procceed(dep_fr, ans_node); } @@ -1150,9 +1164,18 @@ while (YOUNGER_CP(DepFr_cons_cp(dep_fr), chain_cp)) { LOCK(DepFr_lock(dep_fr)); ans_node = DepFr_last_answer(dep_fr); - if (TrNode_child(ans_node)) { - /* dependency frame with unconsumed answers */ - ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#ifdef MODE_DIRECTED_TABLING + ans_node_ptr aux_ans_node = ans_node; + do { + ans_node=TrNode_child(ans_node); + } while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node)); + if (ans_node){ + TrNode_child(aux_ans_node)=ans_node; +#else + if (TrNode_child(ans_node)) + /* dependency frame with unconsumed answers */ + ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#endif /*MODE_DIRECTED_TABLING*/ #ifdef YAPOR if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), top_chain_cp)) #endif /* YAPOR */ @@ -1392,9 +1415,18 @@ while (YOUNGER_CP(DepFr_cons_cp(dep_fr), B)) { LOCK(DepFr_lock(dep_fr)); ans_node = DepFr_last_answer(dep_fr); - if (TrNode_child(ans_node)) { - /* dependency frame with unconsumed answers */ - ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#ifdef MODE_DIRECTED_TABLING + ans_node_ptr aux_ans_node = ans_node; + do { + ans_node=TrNode_child(ans_node); + } while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node)); + if (ans_node){ + TrNode_child(aux_ans_node)=ans_node; +#else + if (TrNode_child(ans_node)) + /* dependency frame with unconsumed answers */ + ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#endif /*MODE_DIRECTED_TABLING*/ if (B->cp_ap) { #ifdef YAPOR if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), B)) @@ -1549,8 +1581,18 @@ LOCK_OR_FRAME(LOCAL_top_or_fr); LOCK(DepFr_lock(LOCAL_top_dep_fr)); ans_node = DepFr_last_answer(LOCAL_top_dep_fr); +#ifdef MODE_DIRECTED_TABLING + ans_node_ptr aux_ans_node = ans_node; + do { + ans_node=TrNode_child(ans_node); + } while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node)); + if (ans_node){ + TrNode_child(aux_ans_node)=ans_node; +#else if (TrNode_child(ans_node)) { - /* unconsumed answer */ + /* unconsumed answer */ + ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node); +#endif /*MODE_DIRECTED_TABLING*/ UNLOCK_OR_FRAME(LOCAL_top_or_fr); ans_node = DepFr_last_answer(LOCAL_top_dep_fr) = TrNode_child(ans_node); UNLOCK(DepFr_lock(LOCAL_top_dep_fr)); diff --git a/OPTYap/tab.macros.h b/OPTYap/tab.macros.h index dd75538b2..d54bec661 100644 --- a/OPTYap/tab.macros.h +++ b/OPTYap/tab.macros.h @@ -269,6 +269,36 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int); #define TrNode_init_lock_field(NODE) #endif /* TABLE_LOCK_AT_NODE_LEVEL */ +#ifdef MODE_DIRECTED_TABLING + +#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY, MODE_DIRECTED_ARRAY)\ + { register sg_node_ptr sg_node; \ + new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \ + ALLOC_TABLE_ENTRY(TAB_ENT); \ + TabEnt_init_lock_field(TAB_ENT); \ + TabEnt_pe(TAB_ENT) = PRED_ENTRY; \ + TabEnt_atom(TAB_ENT) = ATOM; \ + TabEnt_arity(TAB_ENT) = ARITY; \ + TabEnt_flags(TAB_ENT) = 0; \ + SetMode_Batched(TabEnt_flags(TAB_ENT)); \ + SetMode_ExecAnswers(TabEnt_flags(TAB_ENT)); \ + SetMode_LocalTrie(TabEnt_flags(TAB_ENT)); \ + TabEnt_mode(TAB_ENT) = TabEnt_flags(TAB_ENT); \ + if (IsMode_Local(yap_flags[TABLING_MODE_FLAG])) \ + SetMode_Local(TabEnt_mode(TAB_ENT)); \ + if (IsMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG])) \ + SetMode_LoadAnswers(TabEnt_mode(TAB_ENT)); \ + if (IsMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG])) \ + SetMode_GlobalTrie(TabEnt_mode(TAB_ENT)); \ + TabEnt_subgoal_trie(TAB_ENT) = sg_node; \ + TabEnt_hash_chain(TAB_ENT) = NULL; \ + TabEnt_next(TAB_ENT) = GLOBAL_root_tab_ent; \ + GLOBAL_root_tab_ent = TAB_ENT; \ + TabEnt_mode_directed_array(TAB_ENT) = MODE_DIRECTED_ARRAY; \ + } + +#else + #define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY) \ { register sg_node_ptr sg_node; \ new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \ @@ -294,6 +324,25 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int); GLOBAL_root_tab_ent = TAB_ENT; \ } +#endif /*MODE_DIRECTED_TABLING*/ + +#ifdef MODE_DIRECTED_TABLING + +#define new_subgoal_frame(SG_FR, CODE, N_VARS_OPERATOR_ARRAY) \ + { register ans_node_ptr ans_node; \ + new_answer_trie_node(ans_node, 0,N_VARS_OPERATOR_ARRAY, NULL, NULL, NULL); \ + ALLOC_SUBGOAL_FRAME(SG_FR); \ + INIT_LOCK(SgFr_lock(SG_FR)); \ + SgFr_code(SG_FR) = CODE; \ + SgFr_state(SG_FR) = ready; \ + SgFr_hash_chain(SG_FR) = NULL; \ + SgFr_answer_trie(SG_FR) = ans_node; \ + SgFr_first_answer(SG_FR) = NULL; \ + SgFr_last_answer(SG_FR) = NULL; \ + SgFr_del_node(SG_FR) = NULL; \ + } +#else + #define new_subgoal_frame(SG_FR, CODE) \ { register ans_node_ptr ans_node; \ new_answer_trie_node(ans_node, 0, 0, NULL, NULL, NULL); \ @@ -306,6 +355,8 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int); SgFr_first_answer(SG_FR) = NULL; \ SgFr_last_answer(SG_FR) = NULL; \ } +#endif /*MODE_DIRECTED_TABLING*/ + #define init_subgoal_frame(SG_FR) \ { SgFr_init_yapor_fields(SG_FR); \ SgFr_state(SG_FR) = evaluating; \ @@ -482,6 +533,40 @@ static inline void adjust_freeze_registers(void) { static inline void mark_as_completed(sg_fr_ptr sg_fr) { LOCK(SgFr_lock(sg_fr)); +#ifdef MODE_DIRECTED_TABLING + + //printf("complete\n"); + ans_node_ptr answer, valid_answer, elim_answer; + answer = SgFr_first_answer(sg_fr); + + while(answer && IS_INVALID_ANSWER_LEAF_NODE(answer)) + answer = TrNode_child(answer); + SgFr_first_answer(sg_fr) = answer; + valid_answer = answer; + + if(answer!= NULL) + answer = TrNode_child(valid_answer); + + while(answer != NULL){ + if (!IS_INVALID_ANSWER_LEAF_NODE(answer)){ + TrNode_child(valid_answer) = answer; + valid_answer = answer; + } + answer = TrNode_child(answer); + } + + //TrNode_child(valid_answer) = NULL; + SgFr_last_answer(sg_fr) = valid_answer; + + elim_answer = SgFr_del_node(sg_fr); + + while(elim_answer){ + answer= TrNode_next(elim_answer); + FREE_ANSWER_TRIE_NODE(elim_answer); + elim_answer = answer; + } + +#endif /*MODE_DIRECTED_TABLING*/ SgFr_state(sg_fr) = complete; UNLOCK(SgFr_lock(sg_fr)); return; diff --git a/OPTYap/tab.structs.h b/OPTYap/tab.structs.h index 09f45cd5f..e465bd1d6 100644 --- a/OPTYap/tab.structs.h +++ b/OPTYap/tab.structs.h @@ -30,6 +30,9 @@ typedef struct table_entry { short execution_mode; /* combines yap_flags with pred_flags */ struct subgoal_trie_node *subgoal_trie; struct subgoal_trie_hash *hash_chain; +#ifdef MODE_DIRECTED_TABLING + int* mode_directed_array; +#endif /*MODE_DIRECTED_TABLING*/ struct table_entry *next; } *tab_ent_ptr; @@ -41,6 +44,9 @@ typedef struct table_entry { #define TabEnt_mode(X) ((X)->execution_mode) #define TabEnt_subgoal_trie(X) ((X)->subgoal_trie) #define TabEnt_hash_chain(X) ((X)->hash_chain) +#ifdef MODE_DIRECTED_TABLING +#define TabEnt_mode_directed_array(X) ((X)->mode_directed_array) +#endif /*MODE_DIRECTED_TABLING*/ #define TabEnt_next(X) ((X)->next) @@ -91,7 +97,9 @@ typedef struct global_trie_node { #define TrNode_sg_fr(X) ((X)->child) #define TrNode_next(X) ((X)->next) #define TrNode_lock(X) ((X)->lock) - +#ifdef MODE_DIRECTED_TABLING +#define TrNode_mode_directed_array(X) ((X)->entry) +#endif /*MODE_DIRECTED_TABLING */ /*********************************************************************** @@ -116,6 +124,9 @@ typedef struct answer_trie_hash { struct answer_trie_node **buckets; int number_of_nodes; struct answer_trie_hash *next; +#ifdef MODE_DIRECTED_TABLING + struct answer_trie_hash *previous; +#endif /*MODE_DIRECTED_TABLING*/ } *ans_hash_ptr; typedef struct global_trie_hash { @@ -137,7 +148,9 @@ typedef struct global_trie_hash { #define Hash_bucket(X,N) ((X)->buckets + N) #define Hash_num_nodes(X) ((X)->number_of_nodes) #define Hash_next(X) ((X)->next) - +#ifdef MODE_DIRECTED_TABLING +#define Hash_previous(X) ((X)->previous) +#endif /*MODE_DIRECTED_TABLING*/ /************************************************************************ @@ -219,6 +232,9 @@ typedef struct subgoal_frame { struct subgoal_frame *previous; #endif /* LIMIT_TABLING */ struct subgoal_frame *next; +#ifdef MODE_DIRECTED_TABLING +struct answer_trie_node *del_node; +#endif /*MODE_DIRECTED_TABLING*/ } *sg_fr_ptr; #define SgFr_lock(X) ((X)->lock) @@ -236,7 +252,9 @@ typedef struct subgoal_frame { #define SgFr_try_answer(X) ((X)->try_answer) #define SgFr_previous(X) ((X)->previous) #define SgFr_next(X) ((X)->next) - +#ifdef MODE_DIRECTED_TABLING +#define SgFr_del_node(X) ((X)->del_node) +#endif /*MODE_DIRECTED_TABLING*/ /************************************************************************************************** SgFr_lock: spin-lock to modify the frame fields. @@ -351,3 +369,35 @@ typedef struct suspension_frame { #define SuspFr_trail_start(X) ((X)->trail_block.block_start) #define SuspFr_trail_size(X) ((X)->trail_block.block_size) #define SuspFr_next(X) ((X)->next) + + +/* ---------------------------- ** +** MODE_DIRECTED_TABLING flags ** +** ---------------------------- */ +#ifdef MODE_DIRECTED_TABLING + +#define MODE_DIRECTED_TAGBITS 4 + +/*indexing*/ +#define MODE_DIRECTED_INDEX 6 +#define MODE_DIRECTED_NINDEX 1 +#define MODE_DIRECTED_ALL 2 + +/*agregation*/ +#define MODE_DIRECTED_MAX 3 +#define MODE_DIRECTED_MIN 4 +#define MODE_DIRECTED_SUM 5 +#define MODE_DIRECTED_LAST 0 + +/* Macros */ + +#define MODE_DIRECTED_index(X) ((X) >> MODE_DIRECTED_TAGBITS) +#define MODE_DIRECTED_n_vars(X) ((X) >> MODE_DIRECTED_TAGBITS) +#define MODE_DIRECTED_operator(X) ((((X) >> MODE_DIRECTED_TAGBITS) << MODE_DIRECTED_TAGBITS) ^ (X)) + +#define TAG_AS_INVALID_ANSWER_LEAF_NODE(NODE,SG_FR) TrNode_parent(NODE) = (ans_node_ptr)((unsigned long int)TrNode_parent(NODE) | 0x2); \ + TrNode_next(NODE) = SgFr_del_node(SG_FR);\ + SgFr_del_node(SG_FR) = NODE + +#define IS_INVALID_ANSWER_LEAF_NODE(NODE) ((unsigned long int)TrNode_parent(NODE) & 0x2) +#endif /*MODE_DIRECTED_TABLING*/ diff --git a/OPTYap/tab.tries.c b/OPTYap/tab.tries.c index f76cb2d6b..b0b2cd6e9 100644 --- a/OPTYap/tab.tries.c +++ b/OPTYap/tab.tries.c @@ -21,6 +21,9 @@ #include "YapHeap.h" #include "tab.macros.h" +#ifdef MODE_DIRECTED_TABLING +static inline ans_node_ptr answer_search_loop2(sg_fr_ptr, ans_node_ptr, Term, int *,int); +#endif /*MODE_DIRECTED_TABLING*/ static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr, sg_node_ptr, Term); static inline sg_node_ptr subgoal_trie_check_insert_gt_entry(tab_ent_ptr, sg_node_ptr, Term); static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr, ans_node_ptr, Term, int); @@ -29,7 +32,6 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr, Term); #ifdef GLOBAL_TRIE_FOR_SUBTERMS static inline gt_node_ptr global_trie_check_insert_gt_entry(gt_node_ptr, Term); #endif /* GLOBAL_TRIE_FOR_SUBTERMS */ - static inline sg_node_ptr subgoal_search_loop(tab_ent_ptr, sg_node_ptr, Term, int *, CELL **); static inline sg_node_ptr subgoal_search_terms_loop(tab_ent_ptr, sg_node_ptr, Term, int *, CELL **); static inline ans_node_ptr answer_search_loop(sg_fr_ptr, ans_node_ptr, Term, int *); @@ -60,6 +62,7 @@ static void free_global_trie_branch(gt_node_ptr, int); static void free_global_trie_branch(gt_node_ptr); #endif /* GLOBAL_TRIE_FOR_SUBTERMS */ + static void traverse_subgoal_trie(sg_node_ptr, char *, int, int *, int, int); static void traverse_answer_trie(ans_node_ptr, char *, int, int *, int, int, int); static void traverse_global_trie(gt_node_ptr, char *, int, int *, int, int); @@ -67,7 +70,266 @@ static void traverse_global_trie_for_term(gt_node_ptr, char *, int *, int *, int static inline void traverse_trie_node(Term, char *, int *, int *, int *, int); static inline void traverse_update_arity(char *, int *, int *); +//---------------------------------------------------------------------------------- +#ifdef MODE_DIRECTED_TABLING +//#define INCLUDE_ANSWER_TRIE_CHECK_INSERT +//#define INCLUDE_ANSWER_SEARCH_LOOP + + +#define ANSWER_CHECK_INSERT_ENTRY(SG_FR, NODE, ENTRY, INSTR) \ + NODE = answer_trie_check_insert_entry(SG_FR, NODE, ENTRY, INSTR) + +void invalidate_answer(ans_node_ptr node,sg_fr_ptr sg_fr) { + + if(node == NULL) + return; + + if(IS_ANSWER_LEAF_NODE(node)){ + TAG_AS_INVALID_ANSWER_LEAF_NODE(node,sg_fr); + return; + } + + if( IS_ANSWER_TRIE_HASH(node)){ + ans_hash_ptr hash; + ans_node_ptr *bucket, *last_bucket, *first_bucket; + hash = (ans_hash_ptr) node; + first_bucket = bucket = Hash_buckets(hash); + last_bucket = bucket + Hash_num_buckets(hash); + do { + invalidate_answer(*bucket,sg_fr); + } while (++bucket != last_bucket); + Hash_next(Hash_previous(hash)) = Hash_next(hash); + FREE_HASH_BUCKETS(first_bucket); + FREE_ANSWER_TRIE_HASH(hash); + } + + else{ + if (! IS_ANSWER_LEAF_NODE(node)) + invalidate_answer(TrNode_child(node),sg_fr); + if (TrNode_next(node)) + invalidate_answer(TrNode_next(node),sg_fr); + FREE_ANSWER_TRIE_NODE(node); + return; + } +} + + +static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr current_node, Term t, int *vars_arity_ptr,int mode) { + CACHE_REGS +#ifdef MODE_GLOBAL_TRIE_LOOP + gt_node_ptr current_node = GLOBAL_root_gt; +#endif /* MODE_GLOBAL_TRIE_LOOP */ + int vars_arity = *vars_arity_ptr; +#if ! defined(MODE_GLOBAL_TRIE_LOOP) || ! defined(GLOBAL_TRIE_FOR_SUBTERMS) + CELL *stack_terms = (CELL *) LOCAL_TrailTop; +#endif /* ! MODE_GLOBAL_TRIE_LOOP || ! GLOBAL_TRIE_FOR_SUBTERMS */ + CELL *stack_vars_base = (CELL *) TR; +#define stack_terms_limit (stack_vars_base + vars_arity) +#ifdef TRIE_COMPACT_PAIRS + int in_pair = 0; +#else +#define in_pair 0 +#endif /* TRIE_COMPACT_PAIRS */ +#ifdef MODE_DIRECTED_TABLING + ans_node_ptr childnode; + Term childterm; +#endif /*MODE_DIRECTED_TABLING*/ + AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1); /* + 1 because initially we stiil haven't done any STACK_POP_DOWN */ + STACK_PUSH_UP(NULL, stack_terms); + +#if defined(MODE_GLOBAL_TRIE_LOOP) + /* for the global trie, it is safe to skip the IsVarTerm() and IsAtomOrIntTerm() tests in the first iteration */ + goto answer_search_loop_non_atomic; +#endif /* MODE_GLOBAL_TRIE_LOOP */ + + if(mode == MODE_DIRECTED_NINDEX && TrNode_child(current_node)) + return NULL; + + + if(mode == MODE_DIRECTED_LAST && TrNode_child(current_node)){ + invalidate_answer(TrNode_child(current_node),sg_fr); + TrNode_child(current_node) = NULL; + } + + do { + if (IsVarTerm(t)) { + t = Deref(t); + if (IsTableVarTerm(t)) { + t = MakeTableVarTerm(VarIndexOfTerm(t)); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair); + } else { + if (vars_arity == MAX_TABLE_VARS) + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: MAX_TABLE_VARS exceeded"); + stack_vars_base[vars_arity] = t; + *((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity); + t = MakeTableVarTerm(vars_arity); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair); + vars_arity = vars_arity + 1; + } +#ifdef TRIE_COMPACT_PAIRS + in_pair = 0; +#endif /* TRIE_COMPACT_PAIRS */ + } else if (IsAtomOrIntTerm(t)) { +#ifdef MODE_DIRECTED_TABLING + //printf("++++++++++++ operador %d \n", mode); + childnode = TrNode_child(current_node); + if(childnode && IsIntTerm(t) && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){ + Int it = IntOfTerm(t); + if(IsIntTerm(TrNode_entry(childnode))){ + childterm = TrNode_entry(childnode); + Int tt = IntOfTerm(childterm); + if((mode ==MODE_DIRECTED_MIN && it < tt ) || (mode ==MODE_DIRECTED_MAX && it > tt) ){ + invalidate_answer(childnode,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); + } + else if((mode ==MODE_DIRECTED_MIN && it > tt) || (mode ==MODE_DIRECTED_MAX && it < tt) ){ + printf("NULL\n"); + return NULL; + } + else if(it == tt){ + current_node = TrNode_child(current_node); + } + } + } + else +#endif /*MODE_DIRECTED_TABLING*/ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); +#ifdef TRIE_COMPACT_PAIRS + in_pair = 0; +#endif /* TRIE_COMPACT_PAIRS */ +#ifdef MODE_TERMS_LOOP + } else { + gt_node_ptr entry_node; +#ifdef GLOBAL_TRIE_FOR_SUBTERMS + entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms); +#else + entry_node = answer_search_global_trie_loop(t, &vars_arity); +#endif /* GLOBAL_TRIE_FOR_SUBTERMS */ + current_node = answer_trie_check_insert_gt_entry(sg_fr, current_node, (Term) entry_node, _trie_retry_gterm + in_pair); +#else /* ! MODE_TERMS_LOOP */ + } else +#if defined(MODE_GLOBAL_TRIE_LOOP) + /* for the global trie, it is safe to start here in the first iteration */ + answer_search_loop_non_atomic: +#endif /* MODE_GLOBAL_TRIE_LOOP */ +#ifdef TRIE_COMPACT_PAIRS + if (IsPairTerm(t)) { + CELL *aux_pair = RepPair(t); + if (aux_pair == PairTermMark) { + t = STACK_POP_DOWN(stack_terms); + if (IsPairTerm(t)) { + aux_pair = RepPair(t); + t = Deref(aux_pair[1]); + if (t == TermNil) { + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair); + } else { + /* AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2); */ + /* AUX_STACK_CHECK_EXPAND is not necessary here because the situation of pushing ** + ** up 3 terms has already initially checked for the CompactPairInit term */ + STACK_PUSH_UP(t, stack_terms); + STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms); + in_pair = 4; + } + STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms); + } else { + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndTerm, _trie_retry_null); + STACK_PUSH_UP(t, stack_terms); + } +#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS) + } else if (current_node != GLOBAL_root_gt) { + gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms); + current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node); +#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */ + } else { + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairInit, _trie_retry_null + in_pair); + t = Deref(aux_pair[1]); + if (t == TermNil) { + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair); + in_pair = 0; + } else { + AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2); + STACK_PUSH_UP(t, stack_terms); + STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms); + in_pair = 4; + } + STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms); + } +#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS) + } else if (current_node != GLOBAL_root_gt) { + gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms); + current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node); +#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */ +#else /* ! TRIE_COMPACT_PAIRS */ +#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS) + if (current_node != GLOBAL_root_gt) { + gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms); + current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node); + } else +#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */ + if (IsPairTerm(t)) { + CELL *aux_pair = RepPair(t); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsPair(NULL), _trie_retry_pair); + AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1); + STACK_PUSH_UP(Deref(aux_pair[1]), stack_terms); + STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms); +#endif /* TRIE_COMPACT_PAIRS */ + } else if (IsApplTerm(t)) { + Functor f = FunctorOfTerm(t); + if (f == FunctorDouble) { + union { + Term t_dbl[sizeof(Float)/sizeof(Term)]; + Float dbl; + } u; + u.dbl = FloatOfTerm(t); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); + } else if (f == FunctorLongInt) { + Int li = LongIntOfTerm (t); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); + } else if (f == FunctorDBRef) { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorDBRef"); + } else if (f == FunctorBigInt) { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorBigInt"); + } else { + int i; + CELL *aux_appl = RepAppl(t); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_appl + in_pair); + AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + ArityOfFunctor(f) - 1); + for (i = ArityOfFunctor(f); i >= 1; i--) + STACK_PUSH_UP(Deref(aux_appl[i]), stack_terms); + } +#ifdef TRIE_COMPACT_PAIRS + in_pair = 0; +#endif /* TRIE_COMPACT_PAIRS */ + } else { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unknown type tag"); +#endif /* MODE_TERMS_LOOP */ + } + t = STACK_POP_DOWN(stack_terms); + } while (t); + + *vars_arity_ptr = vars_arity; + return current_node; + +#undef stack_terms_limit +#ifndef TRIE_COMPACT_PAIRS +#undef in_pair +#endif /* TRIE_COMPACT_PAIRS */ +} + +//#undef INCLUDE_ANSWER_TRIE_CHECK_INSERT +//#undef INCLUDE_ANSWER_SEARCH_LOOP +#endif /* MODE_DIRECTED_TABLING*/ + +//----------------------------------------------------------------------------------------------------------------- /******************************* ** Structs & Macros ** *******************************/ @@ -971,6 +1233,7 @@ static inline void traverse_update_arity(char *str, int *str_index_ptr, int *ari *******************************/ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) { +// printf("subgoal_search\n"); CACHE_REGS CELL *stack_vars; int i, subs_arity, pred_arity; @@ -987,12 +1250,41 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) { LOCK(TabEnt_lock(tab_ent)); #endif /* TABLE_LOCK_LEVEL */ +#ifdef MODE_DIRECTED_TABLING + int* mode_directed_array = TabEnt_mode_directed_array(tab_ent); + int* n_vars_operator_array = NULL; + int j, old_subs_arity=0; + if(mode_directed_array) + ALLOC_BLOCK(n_vars_operator_array,pred_arity*sizeof(int),int); + + // ALLOC_BLOCK(number_vars,sizeof(int),int); + //for(i=0;i= 1; i--) { TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i])); @@ -1050,7 +1354,26 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) { } else { for (i = subs_arity; i >= 1; i--) { TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i])); +#ifdef MODE_DIRECTED_TABLING + if(n_vars_operator_array){ + while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j])) + j++; + if(!(n_vars < MODE_DIRECTED_n_vars(n_vars_operator_array[j]))){ + j++; + while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j])) + j++; + n_vars = 0; + } + mode = MODE_DIRECTED_operator(n_vars_operator_array[j]); + //printf("operador %d\n",mode); + n_vars++; + } + current_ans_node = answer_search_loop2(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity, mode); + if(current_ans_node == NULL) + break; +#else current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity); +#endif /*MODE_DIRECTED_TABLING*/ } } @@ -1392,4 +1715,6 @@ void show_global_trie(int show_mode, IOSTREAM *out) { } return; } -#endif /* TABLING */ + + +#endif /* TABLING */ \ No newline at end of file diff --git a/OPTYap/tab.tries.i b/OPTYap/tab.tries.i index b6eea1ba8..23aad2ae9 100644 --- a/OPTYap/tab.tries.i +++ b/OPTYap/tab.tries.i @@ -51,7 +51,7 @@ #ifdef MODE_GLOBAL_TRIE_LOOP #define SUBGOAL_CHECK_INSERT_ENTRY(TAB_ENT, NODE, ENTRY) \ NODE = global_trie_check_insert_entry(NODE, ENTRY) -#define ANSWER_CHECK_INSERT_ENTRY(SG_FR, NODE, ENTRY, INSTR) \ +#define ANSWER_CHECK_INSERT_ENTRY(SG_FR, NODE, ENTRY, INSTR) \ NODE = global_trie_check_insert_entry(NODE, ENTRY) #else #define SUBGOAL_CHECK_INSERT_ENTRY(TAB_ENT, NODE, ENTRY) \ @@ -1061,14 +1061,14 @@ static inline ans_node_ptr answer_search_loop(sg_fr_ptr sg_fr, ans_node_ptr curr t = Deref(t); if (IsTableVarTerm(t)) { t = MakeTableVarTerm(VarIndexOfTerm(t)); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair); } else { if (vars_arity == MAX_TABLE_VARS) Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: MAX_TABLE_VARS exceeded"); stack_vars_base[vars_arity] = t; *((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity); t = MakeTableVarTerm(vars_arity); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_var + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair); vars_arity = vars_arity + 1; } #ifdef TRIE_COMPACT_PAIRS diff --git a/pl/tabling.yap b/pl/tabling.yap index 65e5049cc..cd6b5beb6 100644 --- a/pl/tabling.yap +++ b/pl/tabling.yap @@ -111,6 +111,17 @@ table(Pred) :- integer(PredArity), functor(PredFunctor,PredName,PredArity), !, '$set_table'(Mod,PredFunctor). +%MODE_DIRECTED_TABLING +'$do_table'(Mod,Pred) :- + Pred=.. L, + L = [X|XS], + %writeln(X), + %writeln(XS), + length(XS,Len), + functor(PredFunctor,X,Len), !, + %writeln('antes'), + '$c_table_mode_directed'(Mod,PredFunctor,XS). +%MODE_DIRECTED_TABLING '$do_table'(Mod,Pred) :- '$do_error'(type_error(callable,Mod:Pred),table(Mod:Pred)). @@ -335,4 +346,4 @@ table_statistics(Stream,Pred) :- '$do_table_statistics'(_,Mod,Pred) :- '$do_error'(type_error(callable,Mod:Pred),table_statistics(Mod:Pred)). -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \ No newline at end of file +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% From f6cc9578ae19b35bf0f190146f0faeb9e72814d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 24 Oct 2011 22:44:41 +0100 Subject: [PATCH 04/40] first cut at emulation for BP C-interface. --- library/dialect/bprolog/fli/bp.h | 141 +++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 library/dialect/bprolog/fli/bp.h diff --git a/library/dialect/bprolog/fli/bp.h b/library/dialect/bprolog/fli/bp.h new file mode 100644 index 000000000..3ff415ee1 --- /dev/null +++ b/library/dialect/bprolog/fli/bp.h @@ -0,0 +1,141 @@ + +#include + +#define TERM YAP_Term + +//extern TERM bp_get_call_arg(int i, int arity); +#define bp_get_call_arg( i, arity) YAP_A(i) + +//extern int bp_is_atom(TERM t) +#define bp_is_atom(t) YAP_IsAtomTerm(t) + +//extern int bp_is_integer(TERM t) +#define bp_is_integer(t) YAP_IsIntTerm(t) + +//extern int bp_is_float(TERM t) +#define bp_is_float(t) YAP_IsFloatTerm(t) + +//extern int bp_is_nil(TERM t) +#define bp_is_nil(t) YAP_IsTermNil(t) + +//extern int bp_is_list(TERM t) +#define bp_is_nil(t) YAP_IsPairTerm(t) + +//extern int bp_is_structure(TERM t) +#define bp_is_nil(t) YAP_IsApplTerm(t) + +//extern int bp_is_compound(TERM t) +#define bp_is_nil(t) ( YAP_IsApplTerm(t) || YAP_IsPairTerm(t) ) + +//extern int bp_is_unifiable(TERM t1, Term t2) +#define bp_is_unifiable(t1, t2) YAP_unifiable_NOT_IMPLEMENTED(t1, t2) + +//extern int bp_is_identical(TERM t1, Term t2) +#define bp_is_identical(t1, t2) YAP_ExactlyEqual(t1, t2) + +// int bp_get_integer(TERM t) +#define bp_get_integer(t) YAP_IntOfTerm(t) + +// double bp_get_float(TERM t) +#define bp_get_float(t) YAP_FloatOfTerm(t) + +// char *bp_get_name(TERM t) +static inline char * +bp_get_name(TERM t) +{ + if (YAP_IsAtomTerm(t)) { + return YAP_AtomName(YAP_AtomOfTerm(t)); + } + if (YAP_IsApplTerm(t)) { + return YAP_AtomName(YAP_NameOfFunctor(YAP_FunctorOfTerm(t))); + } + // exception = illegal_arguments; + return NULL; +} + + +// char *bp_get_name(TERM t) +static inline int +bp_get_arity(TERM t) +{ + if (YAP_IsAtomTerm(t)) { + return 0; + } + if (YAP_IsApplTerm(t)) { + return (int)YAP_ArityOfFunctor(YAP_FunctorOfTerm(t))); + } + // exception = illegal_arguments; + return NULL; +} + +//extern int bp_unify(TERM t1, TERM t2) +#define bp_unify(t1, t2) YAP_Unify(t1, t2) + +//TERM bp_get_arg(int i, TERM t) +#define bp_get_arg(i, t) YAP_ArgOfTerm(i, t) + +//TERM bp_get_car(Term t) +#define bp_get_car(t) YAP_HeadOfTerm(i, t) + +//TERM bp_get_cdr(Term t) +#define bp_get_cdr(t) YAP_TailOfTerm(i, t) + +// void bp_write(TERM t) +#define bp_write(t) YAP_WriteTerm(t, NULL, 0) + +// TERM bp_build_var() +#define bp_build_var(t) YAP_MkVarTerm() + +// TERM bp_build_integer(int i) +#define bp_build_integer(i) YAP_MkIntTerm(i) + +// TERM bp_build_float(double f) +#define bp_build_float(f) YAP_MkFloatTerm(f) + +// TERM bp_build_atom(char *name) +#define bp_build_atom(name) YAP_MkAtomTerm(YAP_LookupAtom(name)) + +// TERM bp_build_nil() +#define bp_build_nil() YAP_TermNil() + +// TERM bp_build_list() +#define bp_build_list() YAP_MkNewPairTerm() + +// TERM bp_build_structure(char *name, int arity) +#define bp_build_structure(name, arity) YAP_MkNewApplTerm(YAP_MkFunctor(YAP_LookupAtom(name),arity), arity) + +// TERM bp_insert_pred(char *name, int arity, int (*func)()) +#define bp_insert_pred(name, arity, func) YAP_UserCPredicate(name, func, arity) + +// int bp_call_string(char *goal) +#define bp_call_string(goal) YAP_RunGoal(YAP_ReadBuffer(goal, NULL)) + +// int bp_call_term(TERM goal) +#define bp_call_term(goal) YAP_RunGoal(goal) + +// void bp_mount_query_string(char *goal) +#define bp_mount_query_string(goal) bp_t = YAP_ReadBuffer(goal, NULL); + +// void bp_mount_query_term(TERM goal) +// #define bp_mount_query_term(goal) bp_t = t; + +// TERM bp_next_solution() +static int bp_next_solution(void) +{ + if (bp_t) { + Term t = bp_t; + bp_t = NULL; + return YAP_RunGoal(YAP_ReadBuffer(goal, NULL)); + } + return YAP_RestartGoal(); +} + + + + + + + + + + From 384ddd84ad9bc022cfbcc3c334d0dc20a6d52b90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 24 Oct 2011 22:46:16 +0100 Subject: [PATCH 05/40] extend interface with IsTermNIl() --- C/c_interface.c | 7 +++++++ include/YapInterface.h | 2 ++ 2 files changed, 9 insertions(+) diff --git a/C/c_interface.c b/C/c_interface.c index 540d0d5ce..c648f78b3 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -513,6 +513,7 @@ X_API int STD_PROTO(YAP_ThreadDestroyEngine,(int)); X_API Term STD_PROTO(YAP_MkBlobTerm,(unsigned int)); X_API void *STD_PROTO(YAP_BlobOfTerm,(Term)); X_API Term STD_PROTO(YAP_TermNil,(void)); +X_API int STD_PROTO(YAP_IsTermNil,(Term)); X_API int STD_PROTO(YAP_AtomGetHold,(Atom)); X_API int STD_PROTO(YAP_AtomReleaseHold,(Atom)); X_API Agc_hook STD_PROTO(YAP_AGCRegisterHook,(Agc_hook)); @@ -3416,6 +3417,12 @@ YAP_TermNil(void) return TermNil; } +X_API int +YAP_IsTermNil(Term t) +{ + return t == TermNil; +} + X_API int YAP_AtomGetHold(Atom at) { diff --git a/include/YapInterface.h b/include/YapInterface.h index b45c37e3b..5cd333869 100644 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -190,6 +190,8 @@ extern X_API int PROTO(YAP_SkipList,(YAP_Term *, YAP_Term **)); /* Term TailOfTerm(Term) */ extern X_API YAP_Term PROTO(YAP_TermNil,(void)); +extern X_API int PROTO(YAP_IsTermNil,(YAP_Term)); + /* YAP_Term MkApplTerm(YAP_Functor f, unsigned int n, YAP_Term[] args) */ extern X_API YAP_Term PROTO(YAP_MkApplTerm,(YAP_Functor,unsigned int,YAP_Term *)); From 73dd81478f94a84003a9d626c2be78b65b60ca57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 24 Oct 2011 22:47:42 +0100 Subject: [PATCH 06/40] B-Prolog suppoty. --- library/dialect/bprolog.yap | 7 + library/dialect/bprolog/actionrules.pl | 440 ++++++++++++++++++ library/dialect/bprolog/arrays.yap | 35 ++ library/dialect/bprolog/compile_foreach.pl | 514 +++++++++++++++++++++ library/dialect/bprolog/foreach.pl | 399 ++++++++++++++++ library/dialect/bprolog/hashtable.yap | 56 +++ 6 files changed, 1451 insertions(+) create mode 100644 library/dialect/bprolog.yap create mode 100644 library/dialect/bprolog/actionrules.pl create mode 100644 library/dialect/bprolog/arrays.yap create mode 100644 library/dialect/bprolog/compile_foreach.pl create mode 100644 library/dialect/bprolog/foreach.pl create mode 100644 library/dialect/bprolog/hashtable.yap diff --git a/library/dialect/bprolog.yap b/library/dialect/bprolog.yap new file mode 100644 index 000000000..cec080621 --- /dev/null +++ b/library/dialect/bprolog.yap @@ -0,0 +1,7 @@ + +:- ensure_loaded(bprolog/arrays). +:- ensure_loaded(bprolog/hashtable). + +%:- ensure_loaded(bprolog/actionrules). +:- ensure_loaded(bprolog/foreach). +%:- ensure_loaded(bprolog/compile_foreach). diff --git a/library/dialect/bprolog/actionrules.pl b/library/dialect/bprolog/actionrules.pl new file mode 100644 index 000000000..cf8c95c13 --- /dev/null +++ b/library/dialect/bprolog/actionrules.pl @@ -0,0 +1,440 @@ +/* + + Author: Bart Demoen, Phuong-Lan Nguyen + E-mail: Bart.Demoen@cs.kuleuven.be, nguyen@uco.fr + WWW: http://www.swi-prolog.org + Copyright (C): 2006, K.U. Leuven + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + + +/* What is this module for ... see bottom of the file */ + +:- module(actionrules,[op(1200,xfx,=>), + op(1200,xfx,?=>), + op(1000,xfy,:::), + post/1, + post_event/2, + post_event_df/2, + post_event_df/3, + register_event/2 + ]). + +:- use_module(library(lists)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% the built-ins and the preds needed in the transformation % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +register_event(event(X,_),G) :- add_attr(X,'$$event',G). +register_event(ins(X),G) :- add_attr(X,'$$ins',G). +register_event(generated,_). % ignore + +add_attr(X,Mod,A) :- + (get_attr(X,Mod,Old) -> + New = [A|Old] + ; + New = [A] + ), + put_attr(X,Mod,New). + +post(event(X,Mes)) :- !, + (get_attr(X,'$$event',Gs) -> + activate_agents_rev(Gs,Mes) + ; + (var(X) -> + true + ; + throw(actionrule(event/2,illegalfirstargument)) + ) + ). +post(ins(X)) :- !, + (get_attr(X,'$$ins',Gs) -> + call_list_rev(Gs) + ; + (var(X) -> + true + ; + throw(actionrule(ins/1,illegalfirstargument)) + ) + ). +post(Event) :- + throw(actionrule(Event,illegalpost)). + +post_event(X,Mes) :- + get_attr(X,'$$event',Gs), !, activate_agents_rev(Gs,Mes). +post_event(X,_) :- + (var(X) -> + true + ; + throw(actionrule(post_event/2,illegalfirstargument)) + ). + +post_event_df(X,Mes) :- + get_attr(X,'$$event',Gs), !, activate_agents1(Gs,Mes). +post_event_df(_,_). + +post_event_df(X,Alive,Mes) :- + get_attr(X,'$$event',Gs), !, activate_agents(Gs,Alive,Mes). +post_event_df(_,_,_). + +'$$ins':attr_unify_hook(AttrX,Y) :- + (var(Y) -> + (get_attr(Y,'$$ins',AttrY) -> + append(AttrX,AttrY,NewAttr) + ; + NewAttr = AttrX + ), + put_attr(Y,ins,NewAttr) + ; + true + ), + call_list_rev(AttrX). + +'$$event':attr_unify_hook(_,_). + +call_list_rev(Goals) :- + reverse(Goals,Gs), + call_list(Gs). + +call_list([]). +call_list([G|Gs]) :- + call(G), + call_list(Gs). + +activate_agents_rev(Goals,M) :- + reverse(Goals,Gs), + activate_agents(Gs,M). + +activate_agents([],_). +activate_agents([G|Gs],Mes) :- + G =.. [N,_|R], + NewG =.. [N,Mes|R], + call(NewG), + activate_agents(Gs,Mes). + +activate_agents([],_,_). +activate_agents([G|Gs],Alive,Mes) :- + (var(Alive) -> + G =.. [N,_|R], + NewG =.. [N,Mes|R], + call(NewG), + activate_agents(Gs,Alive,Mes) + ; + true + ). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% ar_translate and helper predicates % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +ars2p(ARs,Det,Head,Program,Errors,TailProgram,TailErrors) :- + copyskel(Head,Skel), + cleanheads(ARs,NewARs,Skel), + Skel =.. [N|Args], + makeagentname(N,AgentName), + NewSkel =.. [AgentName,Mes,Alive|Args], + findmess(NewARs,Mes), + genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram1,TailErrors1), + gensecondclause(NewARs,Det,NewSkel,Alive,TailProgram1,TailErrors1,TailProgram,TailErrors). + +genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram,TailErrors) :- + Clause = (Skel :- (Closure = NewSkel), Body), + makefirstbody(NewARs,Det,Closure,Body,Errors,TailErrors), + Program = [Clause | TailProgram]. + + +build_conditional(det, Guard, B, (Guard -> B)). +build_conditional(nondet, Guard, B, (Guard, B)). + +makefirstbody([ar(Head,Guard,Events,B)|R],Det,Closure,Bodys,Errors,TailErrors) :- + (Events == [] -> + build_conditional(Det, Guard, B, Body), + Errors = Errors1 + ; + check_events(Events,Head,Errors,Errors1), + mkregistergoals(Events,Register,Closure), + (member(generated,Events) -> + build_conditional(Det, Guard, (Register,B), Body) + ; + build_conditional(Det, Guard, Register, Body) + ) + ), + (R == [] -> + Bodys = Body, + Errors1 = TailErrors + ; + Bodys = (Body ; MoreBody), + makefirstbody(R,Det,Closure,MoreBody,Errors1,TailErrors) + ). + +gensecondclause(NewARs,Det,NewSkel,Alive,Program,Errors,TailProgram,Errors) :- + Clause = (NewSkel :- (var(Alive) -> Body ; true)), + makesecondbody(NewARs,Det,NewSkel,Body,Alive), + Program = [Clause | TailProgram]. + +makesecondbody([ar(_,Guard,Events,B)|R],Det,NewSkel,Bodys,Alive) :- + (Events == [] -> + build_conditional(Det, Guard, (Alive = no, B), Body) + ; + build_conditional(Det, Guard, B, Body) + ), + (R == [] -> + Bodys = Body + ; + Bodys = (Body ; MoreBody), + makesecondbody(R,Det,NewSkel,MoreBody,Alive) + ). + +check_events([],_,E,E). +check_events([Event|R],S,E,TailE) :- + (nonvar(Event), okevent(Event) -> + E = E1 + ; + E = [illegalevent(Event,S)|E1] + ), + check_events(R,S,E1,TailE). + +okevent(ins(X)) :- !, var(X). +okevent(event(X,M)) :- !, var(X), var(M). +okevent(generated). + +findmess([],_). +findmess([ar(_,_,Events,_)|R],Mes) :- + findmess2(Events,Mes), + findmess(R,Mes). + +findmess2([],_). +findmess2([A|R],Mes) :- + (A = event(_,Mes) -> + true + ; + true + ), + findmess2(R,Mes). + +copyskel(T1,T2) :- + functor(T1,N,A), + functor(T2,N,A). + +cleanheads([],[],_). +cleanheads([ar(Head,Conds,Events,Body)|R],[ar(NewHead,NewConds,Events,Body)|S],Skel) :- + makenewhead(Head,NewHead,Unies), + Skel = NewHead, + append(Unies,Conds,LNewConds), + conds_to_goals(LNewConds, NewConds0), + removetrue(NewConds0, NewConds), + cleanheads(R,S,Skel). + +conds_to_goals([], true) :- !. +conds_to_goals(C.LNewConds, (C,NewConds0)) :- !, + conds_to_goals(LNewConds, NewConds0). +conds_to_goals(C,C). + +makenewhead(Head,NewHead,Unies) :- + Head =.. [_|Args], + functor(Head,N,A), + functor(NewHead,N,A), + NewHead =.. [_|NewArgs], + makeunies(Args,NewArgs,Unies). + +makeunies([],_,[]). +makeunies([X|R],[Y|S],Us) :- + (var(X) -> + X = Y, + Us = Us2 + ; + Us = [X=Y|Us2] % this should be matching instead of unification + ), + makeunies(R,S,Us2). + + +get_arinfo(AR,ARInfo,Head) :- + AR = (Something => Body), + (Something = (Head,Rest) -> + findcondevents(Rest,Conds,Events) + ; + Something = Head, Conds = true, Events = [] + ), + ARInfo = ar(Head,Conds,Events,Body). +get_arinfo(AR,ARInfo,Head) :- + AR = (Something ?=> Body), + (Something = (Head,Rest) -> + findcondevents(Rest,Conds,Events) + ; + Something = Head, Conds = true, Events = [] + ), + ARInfo = ar(Head,Conds,Events,Body). +get_arinfo(AR,ARInfo,Head) :- + AR = (Head :- Rest ::: Body), + Conds = Rest, Events = [], + ARInfo = ar(Head,Conds,Events,Body). + +findcondevents((A,B),(A,As),Ts) :- !, + findcondevents(B,As,Ts). +findcondevents({Trs},true,Ts) :- !, + makeevents(Trs,Ts). +findcondevents(A,A,[]). + +makeevents((A,B),[A|R]) :- !, makeevents(B,R). +makeevents(A,[A]). + +samehead(A,B) :- + functor(A,X,Y), + functor(B,X,Y). + +makeagentname(N,Out) :- + name(N,NL), + name('$$suspended_',A), + append(A,NL,ANL), + name(Out,ANL). + +mkregistergoals([],true,_). +mkregistergoals([X|R],Register,Skel) :- + (X == generated -> + mkregistergoals(R,Register,Skel) + ; + Register = (register_event(X,Skel),S), + mkregistergoals(R,S,Skel) + ). + +removetrue(true,true) :- !. +removetrue((true,A),AA) :- !, removetrue(A,AA). +removetrue((A,true),AA) :- !, removetrue(A,AA). +removetrue((A,B),(AA,BB)) :- !, removetrue(A,AA), removetrue(B,BB). +removetrue((A->B),(AA->BB)) :- !, removetrue(A,AA), removetrue(B,BB). +removetrue((A;B),(AA;BB)) :- !, removetrue(A,AA), removetrue(B,BB). +removetrue(X,X). + + +ar_translate([],_,[],[]). +ar_translate([AR|ARs],Module,Program,Errors) :- + get_head(AR,ARHead), + collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs), + ars2p([AR|ActionPredRest],det,ARHead,Program,Errors,TailProgram,TailErrors), + ar_translate(RestARs,Module,TailProgram,TailErrors). + +nondet_ar_translate([],_,Program,Program,[]). +nondet_ar_translate([AR|ARs],Module,Program,EndProgram,Errors) :- + get_head(AR,ARHead), + collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs), + ars2p([AR|ActionPredRest],nondet,ARHead,Program,Errors,TailProgram,TailErrors), + nondet_ar_translate(RestARs,Module,TailProgram, EndProgram,TailErrors). + +collect_ars_same_head([],_,[],[]). +collect_ars_same_head([AR1|ARs],Head,SameHeadARs,RestARs) :- + get_head(AR1,Head1), + (same_head(Head1,Head) -> + SameHeadARs = [AR1|SameHeadARsRest], + collect_ars_same_head(ARs,Head,SameHeadARsRest,RestARs) + ; + RestARs = [AR1|RestARsRest], + collect_ars_same_head(ARs,Head,SameHeadARs,RestARsRest) + ). + +get_head(ar(Head,_Conds,_Events,_Body),Head). + +same_head(T1,T2) :- + functor(T1,N,A), + functor(T2,N,A). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +ar_expand(Term, []) :- + Term = (_ => _), !, + prolog_load_context(file,File), + get_arinfo(Term,ARInfo,_), + assert(ar_term(File,ARInfo)). +ar_expand(Term, []) :- + Term = (_ :- _ ::: _), !, + prolog_load_context(file,File), + get_arinfo(Term,ARInfo,_), + assert(ar_term(File,ARInfo)). +ar_expand(Term, []) :- + Term = (_ ?=> _ ), !, + prolog_load_context(file,File), + get_arinfo(Term,ARInfo,_), + assert(nondet_ar_term(File,ARInfo)). +ar_expand(end_of_file, FinalProgram) :- + prolog_load_context(file,File), + compile_ar(File, DetProgram), + compile_nondet_ar(File, FinalProgram, DetProgram). + +compile_ar(File, FinalProgram) :- + findall(T, retract(ar_term(File,T)), ARs), + ARs \== [], + prolog_load_context(module, Module), + ar_translate(ARs, Module, FinalProgram, Errors), + !, % just to make sure there are no choice points left + (Errors == [] -> + true + ; + report_errors(Errors) + ). +compile_nondet_ar(File, FinalProgram, StartProgram) :- + findall(T, retract(nondet_ar_term(File,T)), ARs), + ARs \== [], + prolog_load_context(module, Module), + nondet_ar_translate(ARs, Module, FinalProgram, StartProgram, Errors), + !, % just to make sure there are no choice points left + (Errors == [] -> + true + ; + report_errors(Errors) + ). + +report_errors(Errors) :- throw(action_rule_error(Errors)). % for now + +/******************************* +* MUST BE LAST! * +*******************************/ + +:- multifile user:term_expansion/2. +:- dynamic user:term_expansion/2. + +user:term_expansion(In, Out) :- + ar_expand(In, Out). + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% What this file is for .... % +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +/* + +Action Rules were defined and implemented first in the context of +B-Prolog and the TOAM by Neng-Fa Zhou - see http://www.probp.com/ + +See http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW456.abs.html +for an explanation what this file is based on. + +Use_module-ing this file will give you an implementation of Action Rules +functionality related to the event patterns ins/1, generated/0 and +event/2. + +It is not a fast implementation in SWI-Prolog, because there isn't any +low-level support. + +If you need more functionality, please contact the authors. + +*/ diff --git a/library/dialect/bprolog/arrays.yap b/library/dialect/bprolog/arrays.yap new file mode 100644 index 000000000..43a319ff4 --- /dev/null +++ b/library/dialect/bprolog/arrays.yap @@ -0,0 +1,35 @@ + +:- module(bparrays, [new_array/2, a2_new/3, a3_new/4. is_array/1, '$aget'/3]). + +:- use_module(library(lists), [flatten/2]). + +new_array(X, Dim.Dims) :- + functor(X, '[]', Dim), + recurse_new_array(0, Dim, Dims, X). + +recurse_new_array(_, _, [], _X) :- !. +recurse_new_array(Dim, Dim, _Dims, _X) :- !. +recurse_new_array(I0, Dim, Dims, X) :- + I is I0+1, + arg(I, X, A), + new_array(A, Dims), + recurse_new_array(0, Dim, Dims, X). + +a2_new(X, Dim1, Dim2) :- + functor(X, '[]', Dim1), + recurse_new_array(0, Dim1, [Dim2], X). + +a2_new(X, Dim1, Dim2, Dim3) :- + functor(X, '.', Dim1), + recurse_new_array(0, Dim1, [Dim2,Dim3], X). + +is_array(X) :- + functor(X, '[]', _Dim). + +'$aget'(A,[],A). +'$aget'(A,I.Is,A) :- + arg(I, A, X), + '$aget'(X,Is,A). + +array_to_list(A, List) :- + flatten(A, List). diff --git a/library/dialect/bprolog/compile_foreach.pl b/library/dialect/bprolog/compile_foreach.pl new file mode 100644 index 000000000..507217b67 --- /dev/null +++ b/library/dialect/bprolog/compile_foreach.pl @@ -0,0 +1,514 @@ +s% File : compile_foreach.pl +% Author : Neng-Fa Zhou +% Updated: June 2009, updated Dec. 2009, updated Sep. 2010 +% Purpose: compile away foreach +/* compile_foreach(Cls,NCls): NCls is a list of clauses obtained by + compiling away foreach calls in Cls. The new predicate introduced + for a foreach is named p_#_i where p is the name of the predicate + in which the foreach occurs and i is a unique integer. +*/ + +:- yap_flag(unknown,error). +:- ensure_loaded(actionrules). +:- op(560,xfx,[..,to,downto]). +:- op(700,xfx,[subset,notin,in,@=]). + +/* +test:- + Cl1=(test1(L):-foreach(I in L, write(I))), + Cl2=(test2(L):-foreach(I in L, ac(S,0), S^1 is S^0+I)), + Cl3=(test3(T):-functor(T,_,N),foreach(I in 1..N, [Ti],ac(S,0), (arg(I,T,Ti),S^1 is S^0+Ti))), + Cl4=(test4(L):-foreach(I in L, ac1(C,[]), C^0=[I|C^1])), + Cl5=(test5:-foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail), + Cl6=(test6:-foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail), + Cl7=(test7(L1,L2):-foreach(X in L1, (write(X),foreach(Y in L2, writeln((X,Y)))))), + Cl8=(p(D1,D3,IN,OUT):- + foreach(E in D3, + [INi,OUTi], + (asp_lib_clone_rel(IN,OUT,INi,OUTi), + (foreach(X in D1, Y in D1,(not diagY(X,Y,E)->asp_lib_add_tuples(OUTi,X,Y);true)), + asp_lib_card_unique(2,INi,OUTi))))), + compile_foreach([Cl1,Cl2,Cl3,Cl4,Cl5,Cl6,Cl7,Cl8],NCls), + (member(NCl,NCls), portray_clause(NCl),fail;true). +*/ +compile_foreach(File):- + $getclauses_read_file(File,'$t.t.t$',0,_Singleton,_Redef,Cls,[]), + compile_foreach(Cls,NCls), + foreach(NCl in NCls, portray_clause(NCl)). + +compile_foreach(Cls,NCls):- + new_hashtable(ProgTab), + compile_foreach(Cls,NCls,NCls1,ProgTab,0), + hashtable_values_to_list(ProgTab,Prog), + retrieve_new_cls(Prog,NCls1). + +retrieve_new_cls([],[]). +retrieve_new_cls([pred(_,_,_,_,_,Cls)|Preds],NCls):- + append_diff(Cls,NCls,NCls1), + retrieve_new_cls(Preds,NCls1). + +compile_foreach([],NCls,NClsR,_ProgTab,_DumNo) => NCls=NClsR. +compile_foreach([Cl|Cls],NCls,NClsR,ProgTab,DumNo) => + NCls=[NCl|NCls1], + expand_constr(Cl,NCl,ProgTab,DumNo,DumNo1), + compile_foreach(Cls,NCls1,NClsR,ProgTab,DumNo1). + +cl_contains_foreach((delay (_H:-(_G : B)))) => + goal_contains_foreach(B,Flag),nonvar(Flag). +cl_contains_foreach((_H:-_G : B)) => + goal_contains_foreach(B,Flag),nonvar(Flag). +cl_contains_foreach((_H:-_G ? B)) => + goal_contains_foreach(B,Flag),nonvar(Flag). +cl_contains_foreach((_H:-B)) => + goal_contains_foreach(B,Flag),nonvar(Flag). + +goal_contains_foreach(G):- + goal_contains_foreach(G,Flag), + nonvar(Flag). + +goal_contains_foreach(_G,Flag), nonvar(Flag) => true. +goal_contains_foreach(G,_Flag), var(G) => true. +goal_contains_foreach((_G : B),Flag) => + goal_contains_foreach(B,Flag). +goal_contains_foreach((_G ? B),Flag) => + goal_contains_foreach(B,Flag). +goal_contains_foreach((A,B),Flag) => + goal_contains_foreach(A,Flag), + goal_contains_foreach(B,Flag). +goal_contains_foreach((A -> B ; C),Flag) => + goal_contains_foreach(A,Flag), + goal_contains_foreach(B,Flag), + goal_contains_foreach(C,Flag). +goal_contains_foreach((A;B),Flag) => + goal_contains_foreach(A,Flag), + goal_contains_foreach(B,Flag). +goal_contains_foreach(not(A),Flag) => + goal_contains_foreach(A,Flag). +goal_contains_foreach(\+(A),Flag) => + goal_contains_foreach(A,Flag). +goal_contains_foreach(Lhs @= Rhs,Flag) => + exp_contains_list_comp(Lhs,Flag), + exp_contains_list_comp(Rhs,Flag). +goal_contains_foreach(E1#=E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(E1#\=E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(E1# + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(E1#= + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(E1#>E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(E1#>=E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +goal_contains_foreach(G,Flag), functor(G,foreach,_) => Flag=1. +goal_contains_foreach(_G,_Flag) => true. + +exp_contains_list_comp(_,Flag), nonvar(Flag) => true. +exp_contains_list_comp([(_ : _)|_],Flag) => Flag=1. +exp_contains_list_comp(E1+E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +exp_contains_list_comp(E1-E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +exp_contains_list_comp(E1*E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +exp_contains_list_comp(E1/E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +exp_contains_list_comp(E1//E2,Flag) => + exp_contains_list_comp(E1,Flag), + exp_contains_list_comp(E2,Flag). +exp_contains_list_comp(-E,Flag) => + exp_contains_list_comp(E,Flag). +exp_contains_list_comp(abs(E),Flag) => + exp_contains_list_comp(E,Flag). +exp_contains_list_comp(sum([(_ : _)|_]),Flag) => Flag=1. +exp_contains_list_comp(min([(_ : _)|_]),Flag) => Flag=1. +exp_contains_list_comp(max([(_ : _)|_]),Flag) => Flag=1. +exp_contains_list_comp(_,_) => true. + +%% +$change_list_comprehension_to_foreach_cmptime(T,I,Is,CallForeach,L):- + $retrieve_list_comp_lvars_goal_cmptime(Is,LocalVars1,Goal1,Is1), + (nonvar(T),T=_^_-> % array access + LocalVars=[TempVar|LocalVars1], + (Goal1==true-> + Goal=(TempVar@=T,L^0=[TempVar|L^1]) + ; + Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1) + ) + ; + LocalVars=LocalVars1, + (Goal1==true-> + Goal=(L^0=[T|L^1]) + ; + Goal=(Goal1->L^0=[T|L^1];L^0=L^1) + ) + ), + append(Is1,[LocalVars,ac1(L,[]),Goal],Is2), + CallForeach=..[foreach,I|Is2]. + +$retrieve_list_comp_lvars_goal_cmptime([],LocalVars,Goal,Is) => + LocalVars=[],Goal=true,Is=[]. +$retrieve_list_comp_lvars_goal_cmptime([E|Es],LocalVars,Goal,Is),E = (_ in _) => + Is=[E|IsR], + $retrieve_list_comp_lvars_goal_cmptime(Es,LocalVars,Goal,IsR). +$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[] => + Is=[],LocalVars=LVars,G=Goal. +$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[_|_] => + Is=[],LocalVars=LVars,G=Goal. +$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[_|_] => + Is=[],LocalVars=LVars,Goal=true. +$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[] => + Is=[],LocalVars=LVars,Goal=true. +$retrieve_list_comp_lvars_goal_cmptime([G],LocalVars,Goal,Is),nonvar(G) => + Is=[],LocalVars=[],G=Goal. + +%% +extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), var(T) => + NT=T,TempCalls=TempCallsR. +extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), T=(_^_) => + TempCalls=[NT @= T|TempCallsR]. +extract_list_comprehension_array_notation(sum(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] => + NT=sum(L), + TempCalls=[L @= T|TempCallsR]. +extract_list_comprehension_array_notation(min(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] => + NT=min(L), + TempCalls=[L @= T|TempCallsR]. +extract_list_comprehension_array_notation(max(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] => + NT=max(L), + TempCalls=[L @= T|TempCallsR]. +extract_list_comprehension_array_notation(X+Y,NT,TempCalls,TempCallsR) => + NT=(NX+NY), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1), + extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR). +extract_list_comprehension_array_notation(X-Y,NT,TempCalls,TempCallsR) => + NT=(NX-NY), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1), + extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR). +extract_list_comprehension_array_notation(X*Y,NT,TempCalls,TempCallsR) => + NT=(NX*NY), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1), + extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR). +extract_list_comprehension_array_notation(X//Y,NT,TempCalls,TempCallsR) => + NT=(NX//NY), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1), + extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR). +extract_list_comprehension_array_notation(X/Y,NT,TempCalls,TempCallsR) => + NT=(NX/NY), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1), + extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR). +extract_list_comprehension_array_notation(abs(X),NT,TempCalls,TempCallsR) => + NT=abs(NX), + extract_list_comprehension_array_notation(X,NX,TempCalls,TempCallsR). +extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR) => + NT=T,TempCalls=TempCallsR. + +compile_foreach_goal(G,NG,PrefixName,ProgTab,DumNo,DumNoR):- + functor(G,_,Arity), + (compile_foreach_retrieve_iterators(G,1,Arity,Is,ACs,LocalVars,Goal)-> + compile_foreach(Is,LocalVars,ACs,Goal,NG,PrefixName,ProgTab,DumNo,DumNoR) + ; + NG=G,DumNo=DumNoR % interpreted + ). + +compile_foreach(Iterators,LocalVars,ACs,G,NG,PrefixName,ProgTab,DumNo,DumNoR):- + initial_acs_map(ACs,ACMap,Init,Fin), + NG=(Init,G1,Fin), + compile_foreach_iterators(Iterators,LocalVars,ACMap,G,G1,PrefixName,ProgTab,DumNo,DumNoR). + +compile_foreach_iterators([],_LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) => + substitute_accumulators(G,G1,ACMap), + expand_constr(G1,NG,PrefixName,ProgTab,DumNo,DumNoR). +compile_foreach_iterators([I in B1..Step..B2|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) => + (var(I)->true; cmp_error(["wrong loop variable: ", I])), + (Step== -1 -> + compile_foreach_range_downto_1(I,B1,B2,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR); + compile_foreach_range_step(I,B1,B2,Step,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR)). +compile_foreach_iterators([I in L..U|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) => + (var(I)->true; cmp_error(["wrong loop variable: ", I])), + compile_foreach_range_upto_1(I,L,U,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR). +compile_foreach_iterators([I in Lst|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) => + compile_foreach_lst(I,Lst,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR). + +compile_foreach_range_upto_1(I,LExp,UExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):- + new_pred_name_foreach(PrefixName,DumNo,NewPredName), + DumNo1 is DumNo+1, + term_variables((IteratorsR,G),AllVars), + extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]), + foreach_accumulator_args(ACMap,ACHeadArgs,[]), + split_acs_map(ACMap,ACMap1,ACMap2), + append(GVars,ACHeadArgs,Args), + foreach_accumulator_args(ACMap2,ACTailArgs,[]), + append(GVars,ACTailArgs,TailArgs), + foreach_end_accumulator_args(ACMap,BodyR1), + CallNewPred=..[NewPredName,Lower,Upper|Args], + NG=(Lower is LExp, Upper is UExp, CallNewPred), + Head=..[NewPredName,Elm,Upper|Args], + Body1=(Elm>Upper : BodyR1), + Tail2=..[NewPredName,Elm1,Upper|TailArgs], + Body2=(G1,Elm1 is Elm+1,Tail2), + Cl1=(Head:-Body1), + copy_term(Cl1,Cl1CP), + Cl2=(Head:-true : Body2), + I=Elm, + copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy), + TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP), + % + compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2), + % + '$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3), + '$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR), + functor(Head,_,Arity), + PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP]), + hashtable_put(ProgTab,NewPredName/Arity,PredDef). + +compile_foreach_range_downto_1(I,UExp,LExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):- + new_pred_name_foreach(PrefixName,DumNo,NewPredName), + DumNo1 is DumNo+1, + term_variables((IteratorsR,G),AllVars), + extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]), + foreach_accumulator_args(ACMap,ACHeadArgs,[]), + split_acs_map(ACMap,ACMap1,ACMap2), + append(GVars,ACHeadArgs,Args), + foreach_accumulator_args(ACMap2,ACTailArgs,[]), + append(GVars,ACTailArgs,TailArgs), + foreach_end_accumulator_args(ACMap,BodyR1), + CallNewPred=..[NewPredName,Upper,Lower|Args], + NG=(Lower is LExp, Upper is UExp, CallNewPred), + Head=..[NewPredName,Elm,Lower|Args], + Body1=(Elm0,Elm>B2Arg : BodyR1), + Cl1=(Head:-Body1), + copy_term(Cl1,Cl1CP), + Body2=(StepArg<0,Elm Args=ArgsR. +foreach_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Args,ArgsR) => + Args=[In,Out|Args1], + foreach_accumulator_args(ACMap,Args1,ArgsR). + +foreach_end_accumulator_args([],Body) => Body=true. +foreach_end_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Body) => + Body=(In=Out,BodyR), + foreach_end_accumulator_args(ACMap,BodyR). + +split_acs_map([],ACMap1,ACMap2) => ACMap1=[],ACMap2=[]. +split_acs_map([ac_inout(Name,In,Out)|ACMap],ACMap1,ACMap2) => + ACMap1=[ac_inout(Name,In,Mid)|ACMap1R], + ACMap2=[ac_inout(Name,Mid,Out)|ACMap2R], + split_acs_map(ACMap,ACMap1R,ACMap2R). + +/* utilities */ +extract_arg_vars([],_I,_Iterators,_LocalVars,_ACMap,Args,ArgsR) => Args=ArgsR. +extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR):-true ? + ($occur(Var,I); + is_a_loop_var(Var,Iterators); + membchk(Var,LocalVars); + foreach_lookup_acmap(Var,1,_,ACMap); + foreach_lookup_acmap(Var,0,_,ACMap)),!, + extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args,ArgsR). +extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR) => + Args=[Var|Args1], + extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args1,ArgsR). + +is_a_loop_var(Var,(I in _)):-true ? $occur(Var,I),!. +is_a_loop_var(Var,(Iterators1,_)):-true ? + is_a_loop_var(Var,Iterators1),!. +is_a_loop_var(Var,(_,Iterators2)) => + is_a_loop_var(Var,Iterators2). + +initial_acs_map([],ACMap,InitCode,FinCode) => ACMap=[],InitCode=true,FinCode=true. +initial_acs_map([AC],ACMap,InitCode,FinCode) => + ACMap=[Triplet], + initial_ac_map(AC,Triplet,InitCode,FinCode). +initial_acs_map([AC|ACs],[Triplet|ACMap],InitCode,FinCode):- + InitCode=(InitCode1,InitCodeR), + FinCode=(FinCode1,FinCodeR), + initial_ac_map(AC,Triplet,InitCode1,FinCode1), + initial_acs_map(ACs,ACMap,InitCodeR,FinCodeR). +initial_acs_map(AC,ACMap,InitCode,FinCode) => + ACMap=[Triplet], + initial_ac_map(AC,Triplet,InitCode,FinCode). + +initial_ac_map(ac(Name,InitVal),ac_inout(Name,NameIn,NameOut),(NameIn=InitVal),(Name=NameOut)). +initial_ac_map(ac1(Name,FinVal),ac_inout(Name,NameIn,NameOut),(Name=NameIn),(NameOut=FinVal)). + +% Replace inputs and outputs in recurrences: A^0 is input and A^1 is output. +substitute_accumulators(Term,NTerm,_ACMap):-var(Term) : + NTerm=Term. +substitute_accumulators(Term,NTerm,_ACMap):-atomic(Term) : + NTerm=Term. +substitute_accumulators(Term,NTerm,ACMap):-Term=(Var^Tail) : + (foreach_lookup_acmap(Var,Tail,NTerm,ACMap)->true; + NTerm=Term). +substitute_accumulators([E|Es],Lst,ACMap) => + Lst=[E1|Es1], + substitute_accumulators(E,E1,ACMap), + substitute_accumulators(Es,Es1,ACMap). +substitute_accumulators(Term,NTerm,ACMap) => + functor(Term,F,N), + functor(NTerm,F,N), + substitute_accumulators(Term,NTerm,1,N,ACMap). + +substitute_accumulators(_Term,_NTerm,I,N,_), I>N => true. +substitute_accumulators(Term,NTerm,I,N,ACMap) => + arg(I,Term,A), + arg(I,NTerm,NA), + substitute_accumulators(A,NA,ACMap), + I1 is I+1, + substitute_accumulators(Term,NTerm,I1,N,ACMap). + +foreach_lookup_acmap(Term,Tail,NTerm,[ac_inout(Term1,In,Out)|_]), Term==Term1 => + (Tail==0->NTerm=In; + Tail==1->NTerm=Out). +foreach_lookup_acmap(Term,Tail,NTerm,[_|ACMap]) => + foreach_lookup_acmap(Term,Tail,NTerm,ACMap). + +new_pred_name_foreach(PrefixName,DumNo,NewPredName):- + number_codes(DumNo,DumNoCodes), + append(PrefixName,[0'_,0'#,0'_|DumNoCodes],NewPredNameCodes), + atom_codes(NewPredName,NewPredNameCodes). + +compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal), I==Arity => + arg(I,G,Goal), + Iterators=[], + (var(ACs)->ACs=[];true), + (var(LocalVars)->LocalVars=[];true). +compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal) => + arg(I,G,A), + (nonvar(A),A=(_ in _) -> + Iterators=[A|Iterators1] + ;I>=Arity-2 -> + (cmp_foreach_check_accumulators(A) -> + Iterators=Iterators1, + (var(ACs)->ACs=A;cmp_error(["two accumulators given separately in foreach"]),fail) + ;cmp_foreach_check_lvars(A)-> + Iterators=Iterators1, + (var(LocalVars)->LocalVars=A;cmp_error(["invalid local variables given in foreach"]),fail) + ;fail + ) + ;fail + ), + I1 is I+1, + compile_foreach_retrieve_iterators(G,I1,Arity,Iterators1,ACs,LocalVars,Goal). + +cmp_foreach_check_lvars([]) => true. +cmp_foreach_check_lvars([X|Xs]) => var(X),cmp_foreach_check_lvars(Xs). + +cmp_foreach_check_accumulators(ac1(_,_)) => true. +cmp_foreach_check_accumulators(ac(_,_)) => true. +cmp_foreach_check_accumulators(Accumulators), Accumulators=[_|_] => + cmp_foreach_check_accumulator_lst(Accumulators). + +cmp_foreach_check_accumulator_lst([]) => true. +cmp_foreach_check_accumulator_lst([X|_]), var(X) => fail. +cmp_foreach_check_accumulator_lst([ac(_,_)|L]) => + cmp_foreach_check_accumulator_lst(L). +cmp_foreach_check_accumulator_lst([ac1(_,_)|L]) => + cmp_foreach_check_accumulator_lst(L). + + + + + + + diff --git a/library/dialect/bprolog/foreach.pl b/library/dialect/bprolog/foreach.pl new file mode 100644 index 000000000..3cad617b6 --- /dev/null +++ b/library/dialect/bprolog/foreach.pl @@ -0,0 +1,399 @@ +% File : foreach.pl +% Author : Neng-Fa Zhou +% Updated: June 2009, updated Dec. 2009, updated Sep. 2010 +% Purpose: an interpreter of foreach/2-10 and list comprehension +/************************************************************************/ + +:- yap_flag(unknown,error). +:- ensure_loaded(actionrules). +:- op(560,xfy,[..,to,downto]). +:- op(700,xfx,[subset,notin,in,@=]). + +:- use_module(library(lists)). + +/* +test:- + L=[1,2,3],foreach(I in L, writeln(I)),fail. +test:- + foreach(I in 1..10,format("~d ",I)),fail. +test:- + foreach(I in 1..2..10,format("~d ",I)),fail. % step = 2 +test:- + foreach(I in 10.. -1.. 1,format("~d ",I)),fail. % step = -1 +test:- + foreach((A,N) in ([a,b],1..2),writeln(A=N)),fail. +test:- + L=[1,2,3],foreach(I in L, ac(S,0), S^1 is S^0+I),writeln(S),fail. +test:- + T=f(1,2,3),functor(T,_,N),foreach(I in 1..N,ac(S,0),(S^1 is S^0+T[I])),writeln(S),fail. +test:- + L=[1,2,3],foreach(I in L, ac1(C,[]), C^0=[I|C^1]),writeln(C),fail. +test:- + foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail. +test:- + foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail. +test:- + foreach(T in ([a,b],1..2),writeln(T)),fail. +test:- + foreach(F in 1.0..0.2..1.5,format("~1f ",F)),fail. +test:- + L @= [I : I in 1..10],writeln(L),fail. +test:- + L @= [I : I in 1..2..10],writeln(L),fail. +test:- + L @= [I : I in 10..-1..1],writeln(L),fail. +test:- + L @=[X : X in 1..5],writeln(L),fail. +test:- + L @= [1 : X in 1..5],writeln(L),fail. +test:- + L @= [Y : X in 1..5],writeln(L),fail. +test:- + L @= [Y : X in 1..5,[Y]],writeln(L),fail. +test:- + L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail. +test:- + L @= [Y : X in [1,2,3], [Y], Y is -X],writeln(L),fail. +test:- + L @=[(A,I): A in [a,b], I in 1..2],writeln(L),fail. +test:- + L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail. +test. +*/ + +Lhs @= Rhs, + Rhs=[(T:I)|Is], + I=(_ in _) => % list comprehension + '$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L), + call(CallForeach), + L @= Lhs. +Lhs @= Rhs, + Lhs=[(T:I)|Is], + I=(_ in _) => % list comprehension + '$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L), + call(CallForeach), + L @= Rhs. +A^Indexes @= Exp => % array access + '$aget'(A,Indexes,T), + Exp @= T. +Exp @= A^Indexes => % array access + '$aget'(A,Indexes,T), + Exp @= T. +Lhs @= Rhs => Lhs=Rhs. + +'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L):- + '$retrieve_list_comp_lvars_goal'(Is,LocalVars1,Goal1,Is1), + (nonvar(T),T=_^_-> % array access + LocalVars=[TempVar|LocalVars1], + (Goal1==true-> + Goal=(TempVar@=T,L^0=[TempVar|L^1]) + ; + Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1) + ) + ; + LocalVars=LocalVars1, + (Goal1==true-> + Goal=(L^0=[T|L^1]) + ; + Goal=(Goal1->L^0=[T|L^1];L^0=L^1) + ) + ), + append(Is1,[LocalVars,ac1(L,[]),Goal],Is2), + CallForeach=..[foreach,I|Is2]. + +'$retrieve_list_comp_lvars_goal'([],LocalVars,Goal,Is) => + LocalVars=[],Goal=true,Is=[]. +'$retrieve_list_comp_lvars_goal'([E|Es],LocalVars,Goal,Is),E = (_ in _) => + Is=[E|IsR], + '$retrieve_list_comp_lvars_goal'(Es,LocalVars,Goal,IsR). +'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[] => + Is=[],LocalVars=LVars,G=Goal. +'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[_|_] => + Is=[],LocalVars=LVars,G=Goal. +'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[_|_] => + Is=[],LocalVars=LVars,Goal=true. +'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[] => + Is=[],LocalVars=LVars,Goal=true. +'$retrieve_list_comp_lvars_goal'([G],LocalVars,Goal,Is) => + Is=[],LocalVars=[],G=Goal. +'$retrieve_list_comp_lvars_goal'(Args,_LocalVars,_Goal,_Is) => + throw(illegal_arguments(list_comprehension(Args))). + +foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9,A10):- + foreach_aux((A1,A2,A3,A4,A5,A6,A7),A8,A9,A10). + +foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9):- + foreach_aux((A1,A2,A3,A4,A5,A6),A7,A8,A9). + +foreach(A1,A2,A3,A4,A5,A6,A7,A8):- + foreach_aux((A1,A2,A3,A4,A5),A6,A7,A8). + +foreach(A1,A2,A3,A4,A5,A6,A7):- + foreach_aux((A1,A2,A3,A4),A5,A6,A7). + +foreach(A1,A2,A3,A4,A5,A6):- + foreach_aux((A1,A2,A3),A4,A5,A6). + +foreach(A1,A2,A3,A4,A5):- + foreach_aux((A1,A2),A3,A4,A5). + +foreach(A1,A2,A3,A4):- + foreach_aux(A1,A2,A3,A4). + +foreach_aux(A1,A2,A3,A4):- + (A2=(_ in _); A2=(_,_)),!, % iterator + foreach_aux((A1,A2),A3,A4). +foreach_aux(A1,A2,A3,A4):- + foreach_check_accumulators(A3),!, + interp_foreach_with_acs(A1,A2,A3,A4). +foreach_aux(A1,A2,A3,A4):- + foreach_check_accumulators(A2),!, + interp_foreach_with_acs(A1,A3,A2,A4). +foreach_aux(A1,A2,A3,A4):- + throw(illegal_arguments(foreach(A1,A2,A3,A4))). + +foreach(A1,A2,A3):- + foreach_aux(A1,A2,A3). + +foreach_aux(A1,A2,A3):- + (A2=(_ in _); A2=(_,_)),!, + interp_foreach((A1,A2),true,[],A3,[],[],_). +foreach_aux(A1,A2,A3):- + foreach_check_accumulators(A2),!, + interp_foreach_with_acs(A1,[],A2,A3). +foreach_aux(A1,A2,A3):- + foreach_check_lvars(A2),!, + interp_foreach(A1,true,A2,A3,[],[],_). + +foreach(Iterators,Goal):- + interp_foreach(Iterators,true,[],Goal,[],[],_). + +interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):- + init_accumulators(Accumulators,ACs0),!, + interp_foreach(Iterators,true,LVars,Goal,[],ACs0,ACs), + fin_accumulators(Accumulators,ACs0,ACs). +interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):- + throw(illegal_arguments(foreach(Iterators,LVars,Accumulators,Goal))). + +interp_foreach((I,Is),IsRest,LVars,Goal,Map,ACs0,ACs):-!, + (IsRest==true->IsRest1=Is;IsRest1=(Is,IsRest)), + interp_foreach(I,IsRest1,LVars,Goal,Map,ACs0,ACs). +interp_foreach(Pattern in D,IsRest,LVars,Goal,Map,ACs0,ACs):- + interp_foreach_term_instance(D,D1,Map), + (var(D1)->handle_exception(instantiation_error,foreach);true), + interp_foreach_in(Pattern,D1,IsRest,LVars,Goal,Map,ACs0,ACs). +interp_foreach(true,true,LVars,Goal,Map,ACs0,ACs):-!, + foreach_copy_accumulators(ACs0,ACs), + interp_foreach_term_instance(Goal,Goal1,LVars,Map,_,ACs0,ACs), + call(Goal1). +interp_foreach(true,Is,LVars,Goal,Map,ACs0,ACs):- + interp_foreach(Is,true,LVars,Goal,Map,ACs0,ACs). + +interp_foreach_in(Var,(L..Step..U),IsRest,LVars,Goal,Map,ACs0,ACs) => + (var(Var)->true;throw(wrong_loop_variable(Var))), + (foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true), + L1 is L, + U1 is U, + Step1 is Step, + foreach_range(Var,L1,U1,Step1,IsRest,LVars,Goal,Map,ACs0,ACs). +interp_foreach_in(Var,L..U,IsRest,LVars,Goal,Map,ACs0,ACs) => + (var(Var)->true;throw(wrong_loop_variable(Var))), + (foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true), + L1 is L, + U1 is U, + foreach_range(Var,L1,U1,1,IsRest,LVars,Goal,Map,ACs0,ACs). +interp_foreach_in(_,[],IsRest,LVars,Goal,Map,ACs0,ACs) => + ACs=ACs0. +interp_foreach_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs):-true ::: + term_variables(E,EVars), + (member(Var,EVars),foreach_lookup_map(Var,_,Map),!,throw(duplicate_loop_variable(Var));true), + foreach_pattern_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs). + +foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step>0,L>U => + ACs0=ACs. +foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step<0,L + ACs0=ACs. +foreach_range(Var,L,U,Step,IsRest,LVars,Goal,Map,ACs0,ACs) => + interp_foreach(IsRest,true,LVars,Goal,[(Var,L)|Map],ACs0,ACs1), + L1 is L+Step, + foreach_range(Var,L1,U,Step,IsRest,LVars,Goal,Map,ACs1,ACs). + +foreach_pattern_in(_Pattern,D,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(D) => + handle_exception(instantiation_error,foreach). +foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs),D=[_|_] => + foreach_pattern_in_list(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs). +foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs) => + foreach_simu_collection_to_tuples(D,Tuples), + foreach_pattern_in_list(Pattern,Tuples,IsRest,LVars,Goal,Map,ACs0,ACs). + +foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(Lst) => + handle_exception(instantiation_error,foreach). +foreach_pattern_in_list(_Pattern,[],_IsRest,_LVars,_Goal,_Map,ACs0,ACs) => + ACs0=ACs. +foreach_pattern_in_list(Pattern,[E|Es],IsRest,LVars,Goal,Map,ACs0,ACs) => + (foreach_update_map(Pattern,E,Map,Map1)-> + interp_foreach(IsRest,true,LVars,Goal,Map1,ACs0,ACs1) + ; + ACs0=ACs1), + foreach_pattern_in_list(Pattern,Es,IsRest,LVars,Goal,Map,ACs1,ACs). +foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs):-true ::: + handle_exception(type_error(list,Lst),foreach). + +foreach_update_map(Var,E,Map0,Map):-var(Var),!,Map=[(Var,E)|Map0]. +foreach_update_map(Pattern,E,Map0,Map):-atomic(Pattern),!,E==Pattern,Map=Map0. +foreach_update_map(Pattern,E,Map0,Map):-nonvar(E), + functor(Pattern,F,N), + functor(E,F,N), + foreach_update_map(Pattern,E,Map0,Map,1,N). + +foreach_update_map(_Pattern,_E,Map0,Map,I,N):-I>N,!,Map=Map0. +foreach_update_map(Pattern,E,Map0,Map,I,N):- + arg(I,Pattern,Ti), + arg(I,E,Ei), + foreach_update_map(Ti,Ei,Map0,Map1), + I1 is I+1, + foreach_update_map(Pattern,E,Map1,Map,I1,N). + +interp_foreach_term_instance(Term,Term1,Map):- + interp_foreach_term_instance(Term,Term1,[],Map,_,[],[]). + +% Replace loop variables with their values; rename local variables; +% replace inputs and outputs in recurrences: A^0 is input and A^1 is output. +interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,_ACs0,_ACs):-var(Term),!, + (foreach_lookup_map(Term,NTerm,Map)->NMap=Map; + membchk(Term,LVars)->NMap=[(Term,NTerm)|Map]; + NTerm=Term,NMap=Map). +interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-atomic(Term),!, + NTerm=Term,NMap=Map. +interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,ACs0,_ACs):- + var(Term),Tail==0, + foreach_lookup_map(Term,NTerm,ACs0),!, + NMap=Map. +interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,_ACs0,ACs):- + var(Term),Tail==1, + foreach_lookup_map(Term,NTerm,ACs),!, + NMap=Map. +interp_foreach_term_instance([E|Es],Lst,LVars,Map,NMap,ACs0,ACs):-!, + Lst=[E1|Es1], + interp_foreach_term_instance(E,E1,LVars,Map,Map1,ACs0,ACs), + interp_foreach_term_instance(Es,Es1,LVars,Map1,NMap,ACs0,ACs). +interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):- + is_array(Term),!, + NTerm=Term,NMap=Map. +interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):- + is_hashtable(Term),!, + NTerm=Term,NMap=Map. +interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,ACs0,ACs):- + functor(Term,F,N), + functor(NTerm,F,N), + interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,1,N,ACs0,ACs). + +interp_foreach_term_instance(_Term,_NTerm,_LVars,Map,NMap,I,N,_,_):-I>N,!, + NMap=Map. +interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,I,N,ACs0,ACs):- + arg(I,Term,A), + arg(I,NTerm,NA), + interp_foreach_term_instance(A,NA,LVars,Map,Map1,ACs0,ACs), + I1 is I+1, + interp_foreach_term_instance(Term,NTerm,LVars,Map1,NMap,I1,N,ACs0,ACs). + +init_accumulators(ac1(Name,_),ACs):-!, ACs=[(Name,_)]. +init_accumulators(ac(Name,Init),ACs):-!, ACs=[(Name,Init)]. +init_accumulators(Accumulators,ACs):-Accumulators=[_|_], + init_accumulator_lst(Accumulators,ACs). + +init_accumulator_lst([],ACs):-!,ACs=[]. +init_accumulator_lst([ac1(Name,_)|Accumulators],ACs):-!, + ACs=[(Name,_)|ACsR], + init_accumulator_lst(Accumulators,ACsR). +init_accumulator_lst([ac(Name,Init)|Accumulators],ACs):- + ACs=[(Name,Init)|ACsR], + init_accumulator_lst(Accumulators,ACsR). + +fin_accumulators(ac1(Name,Fin),[(_,Init)],[(_,Val)]):-!, + Name=Init,Fin=Val. +fin_accumulators(ac(Name,_),_,[(_,Val)]):-!, Name=Val. +fin_accumulators(Accumulators,ACs0,ACs):-Accumulators=[_|_], + fin_accumulator_lst(Accumulators,ACs0,ACs). + +fin_accumulator_lst([],_,_). +fin_accumulator_lst([ac1(Name,Fin)|Accumulators],[(_,Init)|ACs0],[(_,Val)|ACs]):-!, + Fin=Val, + Name=Init, + fin_accumulator_lst(Accumulators,ACs0,ACs). +fin_accumulator_lst([ac(Name,_)|Accumulators],[_|ACs0],[(_,Val)|ACs]):- + Name=Val, + fin_accumulator_lst(Accumulators,ACs0,ACs). + +foreach_copy_accumulators([],ACs):-!, ACs=[]. +foreach_copy_accumulators([(Name,_)|ACs0],ACs):- + ACs=[(Name,_)|ACs1], + foreach_copy_accumulators(ACs0,ACs1). + +foreach_check_lvars([]):-true ::: true. +foreach_check_lvars([X|Xs]):- var(X) ::: foreach_check_lvars(Xs). +foreach_check_lvars(Xs):-true ::: + throw(illegal_local_variables(Xs)). + +foreach_check_accumulators(ac1(_,_)):-!. +foreach_check_accumulators(ac(_,_)):-!. +foreach_check_accumulators(Accumulators):-Accumulators=[_|_], + foreach_check_accumulator_lst(Accumulators). + +foreach_check_accumulator_lst([]). +foreach_check_accumulator_lst([X|_]):-var(X),!,fail. +foreach_check_accumulator_lst([ac(_,_)|L]):-!, + foreach_check_accumulator_lst(L). +foreach_check_accumulator_lst([ac1(_,_)|L]):- + foreach_check_accumulator_lst(L). + +foreach_lookup_map(Term,NTerm,[(Term1,NTerm1)|_]):-Term==Term1,!, + NTerm=NTerm1. +foreach_lookup_map(Term,NTerm,[_|Map]):- + foreach_lookup_map(Term,NTerm,Map). + +foreach_simu_collection_to_tuples((C1,C2,C3),Tuples) ?=> + foreach_collection_to_lst(C1,L1), + foreach_collection_to_lst(C2,L2), + foreach_collection_to_lst(C3,L3),!, + (foreach_simu_collection_to_tuples3(L1,L2,L3,Tuples)->true; + handle_exception(wrong_collection_in_foreach,(C1,C2,C3))). +foreach_simu_collection_to_tuples((C1,C2),Tuples) ?=> + foreach_collection_to_lst(C1,L1), + foreach_collection_to_lst(C2,L2),!, + (foreach_simu_collection_to_tuples2(L1,L2,Tuples)->true; + handle_exception(wrong_collection_in_foreach,(C1,C2))). +foreach_simu_collection_to_tuples(CTuple,_) => + handle_exception(wrong_collection_in_foreach,CTuple). + +foreach_collection_to_lst([],L) => L=[]. +foreach_collection_to_lst(C,L),C=[_|_] => L=C. +foreach_collection_to_lst((B1..Step..B2),L) => + NB1 is B1, + NB2 is B2, + NStep is Step, + foreach_eval_range(NB1,NB2,NStep,L). +foreach_collection_to_lst((B1..B2),L) => + NB1 is B1, + NB2 is B2, + foreach_eval_range(NB1,NB2,1,L). +foreach_collection_to_lst(CTuple,L),CTuple=(_,_) => + foreach_simu_collection_to_tuples(CTuple,L). +foreach_collection_to_lst(Collection,_L) => + handle_exception(wrong_collection_in_foreach,Collection). + +foreach_eval_range(B1,B2,Step,L),Step>0,B1>B2 => L=[]. +foreach_eval_range(B1,B2,Step,L),Step<0,B1 L=[]. +foreach_eval_range(B1,B2,Step,L) => L=[B1|LR], + NB1 is B1+Step, + foreach_eval_range(NB1,B2,Step,LR). + +foreach_simu_collection_to_tuples3([],[],[],Tuples) => Tuples=[]. +foreach_simu_collection_to_tuples3([X1|L1],[X2|L2],[X3|L3],Tuples) => + Tuples=[(X1,X2,X3)|TuplesR], + foreach_simu_collection_to_tuples3(L1,L2,L3,TuplesR). + +foreach_simu_collection_to_tuples2([],[],Tuples) => Tuples=[]. +foreach_simu_collection_to_tuples2([X1|L1],[X2|L2],Tuples) => + Tuples=[(X1,X2)|TuplesR], + foreach_simu_collection_to_tuples2(L1,L2,TuplesR). diff --git a/library/dialect/bprolog/hashtable.yap b/library/dialect/bprolog/hashtable.yap new file mode 100644 index 000000000..983b5a69b --- /dev/null +++ b/library/dialect/bprolog/hashtable.yap @@ -0,0 +1,56 @@ +:- module(bphash, [new_hashtable/1, + new_hashtable/2, + is_hashtable/1, + hashtable_get/3, + hashtable_put/3, + hashtable_register/3, + hashtable_size/2, + hashtable_to_list/2, + hashtable_values_to_list/2, + hashtable_keys_to_list/2]). + +:- use_module(library(bhash), [b_hash_new/2, + is_b_hash/1, + b_hash_lookup/3, + b_hash_insert/3, + b_hash_size/2, + b_hash_to_list/2, + b_hash_values_to_list/2, + b_hash_keys_to_list/2]). + +new_hashtable(Hash) :- + b_hash_new(Hash, 7). + +new_hashtable(Hash, Size) :- + b_hash_new(Hash, Size). + +is_hashtable(Hash) :- + is_b_hash(Hash). + +hashtable_get(Hash, Key, Value) :- + b_hash_lookup(Key, Value, Hash). + +hashtable_put(Hash, Key, Value) :- + b_hash_insert(Key, Value, Hash). + +hashtable_register(Hash, Key, Value) :- + b_hash_lookup(Key, Value0, Hash), !, + Value0 = Value. +hashtable_register(Hash, Key, Value) :- + b_hash_insert(Hash, Key, Value). + +hashtable_size(Hash, Size) :- + b_hash_size(Hash, Size). + +hashtable_to_list(Hash, List) :- + b_hash_to_list(Hash, List). + +hashtable_keys_to_list(Hash, List) :- + b_hash_keys_to_list(Hash, List). + +hashtable_values_to_list(Hash, List) :- + b_hash_values_to_list(Hash, List). + + + + From c57fbf40e641dc91652896ebd8d23ed5a451e498 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 24 Oct 2011 22:49:42 +0100 Subject: [PATCH 07/40] extend support for hash tables. --- library/bhash.yap | 47 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) diff --git a/library/bhash.yap b/library/bhash.yap index fef13940e..8049f22f3 100644 --- a/library/bhash.yap +++ b/library/bhash.yap @@ -17,7 +17,13 @@ It relies on dynamic array code. b_hash_update/3, b_hash_update/4, b_hash_insert_new/4, - b_hash_insert/4 + b_hash_insert/4, + b_hash_size/2, + b_hash_code/2, + is_b_hash/1, + b_hash_to_list/2, + b_hash_values_to_list/2, + b_hash_keys_to_list/2 ]). :- use_module(library(terms), [ term_hash/4 ]). @@ -27,6 +33,9 @@ It relies on dynamic array code. array_default_size(2048). +is_b_hash(V) :- !, fail. +is_b_hash(hash(_,_,_,_,_)). + b_hash_new(hash(Keys, Vals, Size, N, _, _)) :- array_default_size(Size), array(Keys, Size), @@ -43,6 +52,8 @@ b_hash_new(hash(Keys,Vals, Size, N, HashF, CmpF), Size, HashF, CmpF) :- array(Vals, Size), create_mutable(0, N). +b_hash_size(hash(_, _, Size, _, _, _), Size). + b_hash_lookup(Key, Val, hash(Keys, Vals, Size, _, F, CmpF)):- hash_f(Key, Size, Index, F), fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex), @@ -188,3 +199,37 @@ cmp_f(F, A, B) :- cmp_f(F, A, B) :- call(F, A, B). +b_hash_to_list(hash(Keys, Vals, _, _, _, _), LKeyVals) :- + Keys =.. LKs, + Vals =.. LVs, + mklistpairs(LKs, LVs, LKeyVals). + +b_hash_keys_to_list(hash(Keys, _, _, _, _, _), LKeys) :- + Keys =.. LKs, + mklistels(LKs, LKeys). + +b_hash_keys_to_list(hash(_, Vals, _, _, _, _), LVals) :- + Vals =.. LVs, + mklisvals(LVs, LVals). + +mklistpairs([], [], []). +mklistpairs(V.LKs, _.LVs, KeyVals) :- var(V), !, + mklistpairs(LKs, LVs, KeyVals). +mklistpairs(K.LKs, V.LVs, (K-VV).KeyVals) :- + get_mutable(VV, V), + mklistpairs(LKs, LVs, KeyVals). + +mklistels([], []). +mklistels(V.Es, NEls) :- var(V), !, + mklistels(Els, Nels). +mklistels(K.Els, K.NEls) :- + mklistels(Els, NEls). + +mklistvals([], []). +mklistvals(V.Es, NVals) :- var(V), !, + mklistvals(Vals, Nvals). +mklistvals(K.Vals, KK.NVals) :- + get_mutable(KK, K), + mklistvals(Vals, NVals). + + From 980c79359fb9ffb41b777a27c43712feba4e0eab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:35:07 +0200 Subject: [PATCH 08/40] Yap_unifiable and YAP_Unifiable. --- C/unify.c | 60 ++++++++++++++++++++++++++++-------------- H/absmi.h | 13 +++++++++ docs/yap.tex | 32 ++++++++++++++++++++-- include/YapInterface.h | 3 +++ 4 files changed, 86 insertions(+), 22 deletions(-) diff --git a/C/unify.c b/C/unify.c index 0ab3c8e9f..86991f907 100644 --- a/C/unify.c +++ b/C/unify.c @@ -605,11 +605,13 @@ InitReverseLookupOpcode(void) } #endif -#define UnifiableGlobalCells(a, b) \ - if((a) > (b)) { \ - Bind_Global_NonAtt((a),(CELL)(b)); \ - } else if((a) < (b)){ \ - Bind_Global_NonAtt((b),(CELL) (a)); \ +#define UnifyAndTrailGlobalCells(a, b) \ + if((a) > (b)) { \ + *(a) = (CELL)(b); \ + DO_TRAIL((a), (CELL)(b)); \ + } else if((a) < (b)){ \ + *(b) = (CELL)(a); \ + DO_TRAIL((b), (CELL)(a)); \ } static int @@ -736,7 +738,8 @@ loop: derefa_body(d1, ptd1, unifiable_comp_nvar_unk, unifiable_comp_nvar_nvar); /* d1 and pt2 have the unbound value, whereas d0 is bound */ - Bind(ptd1, d0); + *(ptd1) = d0; + DO_TRAIL(ptd1, d0); continue; } @@ -752,12 +755,13 @@ loop: deref_head(d1, unifiable_comp_var_unk); unifiable_comp_var_nvar: /* pt2 is unbound and d1 is bound */ - Bind(ptd0, d1); + *ptd0 = d1; + DO_TRAIL(ptd0, d1); continue; derefa_body(d1, ptd1, unifiable_comp_var_unk, unifiable_comp_var_nvar); /* ptd0 and ptd1 are unbound */ - UnifiableGlobalCells(ptd0, ptd1); + UnifyAndTrailGlobalCells(ptd0, ptd1); } } /* Do we still have compound terms to visit */ @@ -879,7 +883,8 @@ unifiable_nvar_nvar: deref_body(d1, pt1, unifiable_nvar_unk, unifiable_nvar_nvar); /* d0 is bound and d1 is unbound */ - Bind(pt1, d0); + *(pt1) = d0; + DO_TRAIL(pt1, d0); return (TRUE); deref_body(d0, pt0, unifiable_unk, unifiable_nvar); @@ -887,18 +892,13 @@ unifiable_nvar_nvar: deref_head(d1, unifiable_var_unk); unifiable_var_nvar: /* pt0 is unbound and d1 is bound */ - Bind(pt0, d1); + *pt0 = d1; + DO_TRAIL(pt0, d1); return TRUE; -#if TRAILING_REQUIRES_BRANCH -unifiable_var_nvar_trail: - DO_TRAIL(pt0); - return TRUE; -#endif - deref_body(d1, pt1, unifiable_var_unk, unifiable_var_nvar); /* d0 and pt1 are unbound */ - UnifyCells(pt0, pt1); + UnifyAndTrailCells(pt0, pt1); return (TRUE); #if THREADS #undef Yap_REGS @@ -914,13 +914,13 @@ unifiable_var_nvar_trail: static Int p_unifiable( USES_REGS1 ) { - tr_fr_ptr trp; + tr_fr_ptr trp, trp0 = TR; Term tf = TermNil; if (!unifiable(ARG1,ARG2)) { return FALSE; } trp = TR; - while (trp != B->cp_tr) { + while (trp != trp0) { Term t[2]; --trp; t[0] = TrailTerm(trp); @@ -931,6 +931,26 @@ p_unifiable( USES_REGS1 ) return Yap_unify(ARG3, tf); } +int +Yap_unifiable( Term d0, Term d1 ) +{ + CACHE_REGS + tr_fr_ptr trp, trp0 = TR; + Term tf = TermNil; + if (!unifiable(d0,d1)) { + return FALSE; + } + trp = TR; + while (trp != trp0) { + Term t; + + --trp; + t = TrailTerm(trp); + RESET_VARIABLE(t); + } + return TRUE; +} + void Yap_InitUnify(void) { @@ -940,7 +960,7 @@ Yap_InitUnify(void) Yap_InitCPred("acyclic_term", 1, p_acyclic, SafePredFlag|TestPredFlag); CurrentModule = TERMS_MODULE; Yap_InitCPred("cyclic_term", 1, p_cyclic, SafePredFlag|TestPredFlag); - Yap_InitCPred("protected_unifiable", 3, p_unifiable, 0); + Yap_InitCPred("unifiable", 3, p_unifiable, 0); CurrentModule = cm; } diff --git a/H/absmi.h b/H/absmi.h index ba5926a6c..a5e6eda21 100644 --- a/H/absmi.h +++ b/H/absmi.h @@ -1583,3 +1583,16 @@ void SET_ASP__(CELL *yreg, Int sz USES_REGS) { #define INITIALIZE_PERMVAR(PTR, V) *(PTR) = (V) #endif +/* l1: bind a, l2 bind b, l3 no binding */ +#define UnifyAndTrailCells(a, b) \ + if((a) > (b)) { \ + if ((a) < H) { *(a) = (CELL)(b); DO_TRAIL((a),(CELL)(b)); } \ + else if ((b) <= H) { *(a) =(CELL)(b); DO_TRAIL((a),(CELL)(b));} \ + else { *(b) = (CELL)(a); DO_TRAIL((b),(CELL)(a)); } \ + } else if((a) < (b)){ \ + if ((b) <= H) { *(b) = (CELL)(a); DO_TRAIL((b),(CELL)(a)); } \ + else if ((a) <= H) { *(b) = (CELL) (a); DO_TRAIL((b),(CELL)(a));} \ + else { *(a) = (CELL) (b); DO_TRAIL((a),(CELL)(b));} \ + } + + diff --git a/docs/yap.tex b/docs/yap.tex index c93c4dd27..dd4d5d2f9 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -16182,6 +16182,27 @@ of non-variable terms: YAP_Bool YAP_IsApplTerm(YAP_Term @var{t}) @end example +The next primitive gives the type of a Prolog term: +@example + YAP_tag_t YAP_TagOfTerm(YAP_Term @var{t}) +@end example +The set of possible values is an enumerated type, with the following values: +@table @i +@item @code{YAP_TAG_ATT}: an attributed variable +@item @code{YAP_TAG_UNBOUND}: an unbound variable +@item @code{YAP_TAG_REF}: a reference to a term +@item @code{YAP_TAG_PAIR}: a list +@item @code{YAP_TAG_ATOM}: an atom +@item @code{YAP_TAG_INT}: a small integer +@item @code{YAP_TAG_LONG_INT}: a word sized integer +@item @code{YAP_TAG_BIG_INT}: a very large integer +@item @code{YAP_TAG_RATIONAL}: a rational number +@item @code{YAP_TAG_FLOAT}: a floating point number +@item @code{YAP_TAG_OPAQUE}: an opaque term +@item @code{YAP_TAG_APPL}: a compound term +@end table + + Next, we mention the primitives that allow one to destruct and construct terms. All the above primitives ensure that their result is @i{dereferenced}, i.e. that it is not a pointer to another term. @@ -16567,14 +16588,14 @@ lead to a crash. The following functions are often required to compare terms. @findex YAP_ExactlyEqual (C-Interface function) -The first function succeeds if two terms are actually the same term, as +Succeed if two terms are actually the same term, as in @code{==/2}: @example int YAP_ExactlyEqual(YAP_Term t1, YAP_Term t2) @end example @noindent -The second function succeeds if two terms are variant terms, and returns +The next function succeeds if two terms are variant terms, and returns 0 otherwise, as @code{=@=/2}: @example @@ -16582,6 +16603,13 @@ The second function succeeds if two terms are variant terms, and returns @end example @noindent +Last, this function succeeds if two terms are unifiable: +@code{=@=/2}: +@example + int YAP_Unifiable(YAP_Term t1, YAP_Term t2) +@end example +@noindent + The second function computes a hash function for a term, as in @code{term_hash/4}. @example diff --git a/include/YapInterface.h b/include/YapInterface.h index 5cd333869..cc6986bdb 100644 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -534,6 +534,7 @@ extern X_API int PROTO(YAP_Erase,(void *)); /* term utilities */ extern X_API int PROTO(YAP_Variant,(YAP_Term,YAP_Term)); +extern X_API int PROTO(YAP_Unifiable,(YAP_Term,YAP_Term)); extern X_API int PROTO(YAP_ExactlyEqual,(YAP_Term,YAP_Term)); extern X_API YAP_Int PROTO(YAP_TermHash,(YAP_Term, YAP_Int, YAP_Int, int)); @@ -570,6 +571,8 @@ extern X_API void *PROTO(YAP_OpaqueObjectFromTerm,(YAP_Term)); extern X_API int *PROTO(YAP_Argv,(char ***)); +extern X_API YAP_tag_t PROTO(YAP_TagOfTerm,(YAP_Term)); + #define YAP_InitCPred(N,A,F) YAP_UserCPredicate(N,F,A) __END_DECLS From 8785108e66d55a04a8bc520ef9a7ded9f965abc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:35:40 +0200 Subject: [PATCH 09/40] Yap_unifiable and TagOfTerm --- C/c_interface.c | 59 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 58 insertions(+), 1 deletion(-) diff --git a/C/c_interface.c b/C/c_interface.c index c648f78b3..a60bad24b 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -425,6 +425,7 @@ X_API Int STD_PROTO(YAP_ArityOfFunctor,(Functor)); X_API void *STD_PROTO(YAP_ExtraSpace,(void)); X_API void STD_PROTO(YAP_cut_up,(void)); X_API Int STD_PROTO(YAP_Unify,(Term,Term)); +X_API int STD_PROTO(YAP_Unifiable,(Term,Term)); X_API int STD_PROTO(YAP_Reset,(void)); X_API Int STD_PROTO(YAP_Init,(YAP_init_args *)); X_API Int STD_PROTO(YAP_FastInit,(char *)); @@ -545,6 +546,7 @@ X_API int STD_PROTO(YAP_NewOpaqueType,(void *)); X_API Term STD_PROTO(YAP_NewOpaqueObject,(int, size_t)); X_API void *STD_PROTO(YAP_OpaqueObjectFromTerm,(Term)); X_API int STD_PROTO(YAP_Argv,(char *** argvp)); +X_API YAP_tag_t STD_PROTO(YAP_TagOfTerm,(Term)); static int dogc( USES_REGS1 ) @@ -1180,6 +1182,18 @@ YAP_Unify(Term t1, Term t2) return out; } +X_API int +YAP_Unifiable(Term t1, Term t2) +{ + int out; + BACKUP_MACHINE_REGS(); + + out = Yap_unifiable(t1, t2); + + RECOVER_MACHINE_REGS(); + return out; +} + /* == */ X_API int YAP_ExactlyEqual(Term t1, Term t2) @@ -3788,7 +3802,6 @@ YAP_OpInfo(Atom at, Term module, int opkind, int *yap_type, int *prio) return 1; } - int YAP_Argv(char ***argvp) { @@ -3797,3 +3810,47 @@ YAP_Argv(char ***argvp) } return GLOBAL_argc; } + +YAP_tag_t +YAP_TagOfTerm(Term t) +{ + if (IsVarTerm(t)) { + CELL *pt = VarOfTerm(t); + if (IsUnboundVar(pt)) { + if (IsAttVar(pt)) + return YAP_TAG_ATT; + return YAP_TAG_UNBOUND; + } + return YAP_TAG_REF; + } + if (IsPairTerm(t)) + return YAP_TAG_PAIR; + if (IsAtomOrIntTerm(t)) { + if (IsAtomTerm(t)) + return YAP_TAG_ATOM; + return YAP_TAG_INT; + } else { + Functor f = FunctorOfTerm(t); + + if (IsExtensionFunctor(f)) { + if (f == FunctorDBRef) { + return YAP_TAG_DBREF; + } + if (f == FunctorLongInt) { + return YAP_TAG_LONG_INT; + } + if (f == FunctorBigInt) { + big_blob_type bt = RepAppl(t)[1]; + switch (bt) { + case BIG_INT: + return YAP_TAG_BIG_INT; + case BIG_RATIONAL: + return YAP_TAG_RATIONAL; + default: + return YAP_TAG_OPAQUE; + } + } + } + return YAP_TAG_APPL; + } +} From 1cc3280fea68e156a82c87431ca2aef9ad60fd4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:36:03 +0200 Subject: [PATCH 10/40] Yap_unifiable --- H/Yapproto.h | 1 + 1 file changed, 1 insertion(+) diff --git a/H/Yapproto.h b/H/Yapproto.h index d75d3ca97..6fa38dff5 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -379,6 +379,7 @@ int STD_PROTO(Yap_rational_tree_loop, (CELL *, CELL *, CELL **, CELL ** void STD_PROTO(Yap_InitAbsmi,(void)); void STD_PROTO(Yap_InitUnify,(void)); void STD_PROTO(Yap_TrimTrail,(void)); +void STD_PROTO(Yap_Unifiable,(Term d0, Term d1)); int STD_PROTO(Yap_IUnify,(register CELL d0,register CELL d1)); /* userpreds.c */ From 1ddd61314c04c9aa74bfdfcbac6dfa577bec4879 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:36:48 +0200 Subject: [PATCH 11/40] support for X^[A,B] and X^length in arithmetic expressions. --- C/eval.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ H/iatoms.h | 1 + H/ratoms.h | 1 + H/tatoms.h | 2 ++ misc/ATOMS | 1 + 5 files changed, 58 insertions(+) diff --git a/C/eval.c b/C/eval.c index 311c96e06..56e6739cc 100644 --- a/C/eval.c +++ b/C/eval.c @@ -34,7 +34,54 @@ static char SccsId[] = "%W% %G%"; #include #endif +static Term Eval(Term t1 USES_REGS); +static Term +get_matrix_element(Term t1, Term t2 USES_REGS) +{ + if (!IsPairTerm(t2)) { + if (t2 == MkAtomTerm(AtomLength)) { + Int sz = 1; + while (IsApplTerm(t1)) { + Functor f = FunctorOfTerm(t1); + if (NameOfFunctor(f) != AtomNil) { + return MkIntegerTerm(sz); + } + sz *= ArityOfFunctor(f); + t1 = ArgOfTerm(1, t1); + } + return MkIntegerTerm(sz); + } + Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); + return FALSE; + } + while (IsPairTerm(t2)) { + Int indx; + Term indxt = Eval(HeadOfTerm(t2) PASS_REGS); + if (!IsIntegerTerm(indxt)) { + Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); + return FALSE; + } + indx = IntegerOfTerm(indxt); + if (!IsApplTerm(t1)) { + Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]"); + return FALSE; + } else { + Functor f = FunctorOfTerm(t1); + if (ArityOfFunctor(f) < indx) { + Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]"); + return FALSE; + } + } + t1 = ArgOfTerm(indx, t1); + t2 = TailOfTerm(t2); + } + if (t2 != TermNil) { + Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]"); + return FALSE; + } + return Eval(t1 PASS_REGS); +} static Term Eval(Term t USES_REGS) @@ -77,6 +124,12 @@ Eval(Term t USES_REGS) "functor %s/%d for arithmetic expression", RepAtom(name)->StrOfAE,n); } + if (p->FOfEE == op_power && p->ArityOfEE == 2) { + t2 = ArgOfTerm(2, t); + if (IsPairTerm(t2)) { + return get_matrix_element(ArgOfTerm(1, t), t2 PASS_REGS); + } + } *RepAppl(t) = (CELL)AtomFoundVar; t1 = Eval(ArgOfTerm(1,t) PASS_REGS); if (t1 == 0L) { diff --git a/H/iatoms.h b/H/iatoms.h index 7d0f51791..c1ec9e52a 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -150,6 +150,7 @@ AtomLT = Yap_LookupAtom("<"); AtomLastExecuteWithin = Yap_FullLookupAtom("$last_execute_within"); AtomLeash = Yap_FullLookupAtom("$leash"); + AtomLength = Yap_FullLookupAtom("length"); AtomList = Yap_LookupAtom("list"); AtomLive = Yap_FullLookupAtom("$live"); AtomLoadAnswers = Yap_LookupAtom("load_answers"); diff --git a/H/ratoms.h b/H/ratoms.h index 9350f03a8..e7bad9b88 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -150,6 +150,7 @@ AtomLT = AtomAdjust(AtomLT); AtomLastExecuteWithin = AtomAdjust(AtomLastExecuteWithin); AtomLeash = AtomAdjust(AtomLeash); + AtomLength = AtomAdjust(AtomLength); AtomList = AtomAdjust(AtomList); AtomLive = AtomAdjust(AtomLive); AtomLoadAnswers = AtomAdjust(AtomLoadAnswers); diff --git a/H/tatoms.h b/H/tatoms.h index f63e9e481..94dd6d799 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -298,6 +298,8 @@ #define AtomLastExecuteWithin Yap_heap_regs->AtomLastExecuteWithin_ Atom AtomLeash_; #define AtomLeash Yap_heap_regs->AtomLeash_ + Atom AtomLength_; +#define AtomLength Yap_heap_regs->AtomLength_ Atom AtomList_; #define AtomList Yap_heap_regs->AtomList_ Atom AtomLive_; diff --git a/misc/ATOMS b/misc/ATOMS index 2bb81f846..f5b660565 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -155,6 +155,7 @@ A LOOP N "_LOOP_" A LT N "<" A LastExecuteWithin F "$last_execute_within" A Leash F "$leash" +A Length F "length" A List N "list" A Live F "$live" A LoadAnswers N "load_answers" From 0ea25a8908c417915fbfb2ce6075eed4342aa410 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:37:26 +0200 Subject: [PATCH 12/40] bprolog support --- Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.in b/Makefile.in index cda4d200e..7f1588a2f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -115,6 +115,7 @@ INTERFACE_HEADERS = \ $(srcdir)/include/yap_structs.h \ $(srcdir)/include/YapInterface.h \ $(srcdir)/include/SWI-Prolog.h \ + $(srcdir)/library/dialect/bprolog/fli/bprolog.h \ $(srcdir)/os/SWI-Stream.h IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \ From fa9d8008a4f7dbe5777dbb89f28e500528dbb856 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:37:41 +0200 Subject: [PATCH 13/40] bug fixes. --- OPTYap/tab.tries.c | 284 ++++++++++++++++++++++++++++++++++++--------- 1 file changed, 232 insertions(+), 52 deletions(-) diff --git a/OPTYap/tab.tries.c b/OPTYap/tab.tries.c index b0b2cd6e9..16cb48855 100644 --- a/OPTYap/tab.tries.c +++ b/OPTYap/tab.tries.c @@ -132,8 +132,8 @@ static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr cur #define in_pair 0 #endif /* TRIE_COMPACT_PAIRS */ #ifdef MODE_DIRECTED_TABLING - ans_node_ptr childnode; - Term childterm; + ans_node_ptr child_node; + Term child_term; #endif /*MODE_DIRECTED_TABLING*/ AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1); /* + 1 because initially we stiil haven't done any STACK_POP_DOWN */ STACK_PUSH_UP(NULL, stack_terms); @@ -172,27 +172,64 @@ static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr cur #endif /* TRIE_COMPACT_PAIRS */ } else if (IsAtomOrIntTerm(t)) { #ifdef MODE_DIRECTED_TABLING - //printf("++++++++++++ operador %d \n", mode); - childnode = TrNode_child(current_node); - if(childnode && IsIntTerm(t) && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){ - Int it = IntOfTerm(t); - if(IsIntTerm(TrNode_entry(childnode))){ - childterm = TrNode_entry(childnode); - Int tt = IntOfTerm(childterm); - if((mode ==MODE_DIRECTED_MIN && it < tt ) || (mode ==MODE_DIRECTED_MAX && it > tt) ){ - invalidate_answer(childnode,sg_fr); + child_node = TrNode_child(current_node); + if(child_node && IsIntTerm(t) && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){ + Int it = IntOfTerm(t); + if(IsIntTerm(TrNode_entry(child_node))){ + child_term = TrNode_entry(child_node); + Int tt = IntOfTerm(child_term); + if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt) ){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); + } + else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) ){ + return NULL; + } + else if (it == tt){ + current_node = TrNode_child(current_node); + } + } + if(IsApplTerm(TrNode_entry(child_node))){ + if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){ + Int tt = TrNode_entry(TrNode_child(child_node)); + if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt)){ + invalidate_answer(child_node,sg_fr); TrNode_child(current_node) = NULL; ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); - } - else if((mode ==MODE_DIRECTED_MIN && it > tt) || (mode ==MODE_DIRECTED_MAX && it < tt) ){ - printf("NULL\n"); - return NULL; - } - else if(it == tt){ - current_node = TrNode_child(current_node); - } - } + } + else if(it == tt){ + current_node = TrNode_child(TrNode_child(child_node)); + } + else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) ) + return NULL; + } + else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){ + union { + Term t_dbl[sizeof(Float)/sizeof(Term)]; + Float dbl; + } u; + u.t_dbl[0] = TrNode_entry(TrNode_child(child_node)); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node))); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + if((mode == MODE_DIRECTED_MIN && it < u.dbl ) || (mode == MODE_DIRECTED_MAX && it > u.dbl)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); + } + else if(it == u.dbl){ +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + current_node = TrNode_child(TrNode_child(TrNode_child(child_node))); +#else + current_node = TrNode_child(TrNode_child(child_node)); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + } + else if((mode == MODE_DIRECTED_MIN && it > u.dbl) || (mode == MODE_DIRECTED_MAX && it < u.dbl)) + return NULL; + } } + } else #endif /*MODE_DIRECTED_TABLING*/ ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair); @@ -283,41 +320,184 @@ static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr cur Float dbl; } u; u.dbl = FloatOfTerm(t); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); +#ifdef MODE_DIRECTED_TABLING + child_node = TrNode_child(current_node); + if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){ + if(IsApplTerm(TrNode_entry(child_node))){ + if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){ + Int tt = TrNode_entry(TrNode_child(child_node)); + if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); #if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); #endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); - } else if (f == FunctorLongInt) { - Int li = LongIntOfTerm (t); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); - } else if (f == FunctorDBRef) { - Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorDBRef"); - } else if (f == FunctorBigInt) { - Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorBigInt"); - } else { - int i; - CELL *aux_appl = RepAppl(t); - ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_appl + in_pair); - AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + ArityOfFunctor(f) - 1); - for (i = ArityOfFunctor(f); i >= 1; i--) - STACK_PUSH_UP(Deref(aux_appl[i]), stack_terms); - } + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); + } + else if(tt == u.dbl){ + current_node = TrNode_child(TrNode_child(child_node)); + } + else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt)) + return NULL; + } + else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){ + union { + Term t_dbl[sizeof(Float)/sizeof(Term)]; + Float dbl; + } ans_u; + ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node)); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node))); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + if(( mode == MODE_DIRECTED_MIN && u.dbl < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl > ans_u.dbl)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); + } + else if(ans_u.dbl == u.dbl){ +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + current_node = TrNode_child(TrNode_child(TrNode_child(child_node))); +#else + current_node = TrNode_child(TrNode_child(child_node)); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + } + else if(( mode == MODE_DIRECTED_MIN && u.dbl > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl < ans_u.dbl)) + return NULL; + } + } + else if(IsIntTerm(TrNode_entry(child_node))){ + Int tt = IntOfTerm(child_node); + if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); + } + else if(IntOfTerm(child_node) == u.dbl){ + current_node = TrNode_child(TrNode_child(child_node)); + } + else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt)) + return NULL; + } + } + else { +#endif /*MODE_DIRECTED_TABLING*/ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double); +#ifdef MODE_DIRECTED_TABLING + } +#endif /*MODE_DIRECTED_TABLING*/ + } else if (f == FunctorLongInt) { + Int li = LongIntOfTerm (t); + child_node = TrNode_child(current_node); +#ifdef MODE_DIRECTED_TABLING + if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){ + if(IsApplTerm(TrNode_entry(child_node))){ + if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){ + Int tt = TrNode_entry(TrNode_child(child_node)); + if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); + + } + else if(li == tt){ + current_node = TrNode_child(TrNode_child(child_node)); + } + else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt)) + return NULL; + } + else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){ + union { + Term t_dbl[sizeof(Float)/sizeof(Term)]; + Float dbl; + } ans_u; + ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node)); +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node))); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + if(( mode == MODE_DIRECTED_MIN && li < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li > ans_u.dbl)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); + } + else if(ans_u.dbl == li){ +#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P + current_node = TrNode_child(TrNode_child(TrNode_child(child_node))); +#else + current_node = TrNode_child(TrNode_child(child_node)); +#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */ + } + else if(( mode == MODE_DIRECTED_MIN && li > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li < ans_u.dbl)) + return NULL; + } + } + else if(IsIntTerm(TrNode_entry(child_node))){ + Int tt = IntOfTerm(child_node); + if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){ + invalidate_answer(child_node,sg_fr); + TrNode_child(current_node) = NULL; + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); + } + else if(li == tt){ + current_node = TrNode_child(TrNode_child(child_node)); + } + else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt)) + return NULL; + } + }else{ +#endif /*MODE_DIRECTED_TABLING*/ + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint); +#ifdef MODE_DIRECTED_TABLING + } +#endif/*MODE_DIRECTED_TABLING*/ + } else if (f == FunctorDBRef) { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorDBRef"); + } else if (f == FunctorBigInt) { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorBigInt"); + } else { + int i; + CELL *aux_appl = RepAppl(t); + ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_appl + in_pair); + AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + ArityOfFunctor(f) - 1); + for (i = ArityOfFunctor(f); i >= 1; i--) + STACK_PUSH_UP(Deref(aux_appl[i]), stack_terms); + } #ifdef TRIE_COMPACT_PAIRS - in_pair = 0; + in_pair = 0; #endif /* TRIE_COMPACT_PAIRS */ - } else { - Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unknown type tag"); + } else { + Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unknown type tag"); #endif /* MODE_TERMS_LOOP */ - } - t = STACK_POP_DOWN(stack_terms); - } while (t); - - *vars_arity_ptr = vars_arity; - return current_node; + } + t = STACK_POP_DOWN(stack_terms); + } while (t); + + *vars_arity_ptr = vars_arity; + return current_node; #undef stack_terms_limit #ifndef TRIE_COMPACT_PAIRS @@ -1370,7 +1550,7 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) { } current_ans_node = answer_search_loop2(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity, mode); if(current_ans_node == NULL) - break; + break; #else current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity); #endif /*MODE_DIRECTED_TABLING*/ @@ -1717,4 +1897,4 @@ void show_global_trie(int show_mode, IOSTREAM *out) { } -#endif /* TABLING */ \ No newline at end of file +#endif /* TABLING */ From 20a1362bf80311c5e6a08ebb026b743b0d701452 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:38:11 +0200 Subject: [PATCH 14/40] bprolog support --- library/Makefile.in | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/library/Makefile.in b/library/Makefile.in index 371be706e..e5be0239a 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -91,6 +91,7 @@ MYDDAS_PROGRAMS= $(srcdir)/MYDDAS/myddas.ypp \ DIALECT_PROGRAMS= \ $(srcdir)/dialect/commons.yap \ + $(srcdir)/dialect/bprolog.yap \ $(srcdir)/dialect/hprolog.yap \ $(srcdir)/dialect/swi.yap @@ -98,6 +99,12 @@ DIALECT_SWI= \ $(srcdir)/dialect/swi/INDEX.pl \ $(srcdir)/dialect/swi/listing.pl +DIALECT_BP= \ + $(srcdir)/dialect/bprolog/actionrules.pl \ + $(srcdir)/dialect/bprolog/compile_foreach.pl \ + $(srcdir)/dialect/bprolog/foreach.pl \ + $(srcdir)/dialect/bprolog/hashtable.yap + install: $(PROGRAMS) install_myddas mkdir -p $(DESTDIR)$(SHAREDIR)/Yap mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect @@ -105,6 +112,7 @@ install: $(PROGRAMS) install_myddas for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done for p in $(DIALECT_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect; done for p in $(DIALECT_SWI); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect/swi; done + for p in $(DIALECT_BP); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect/bprolog; done install_myddas: $(MYDDAS_PROGRAMS) count=`echo "$(YAP_EXTRAS)" | grep MYDDAS | wc -l`; \ From 1769fc7313b906e59e668a51dc7b0906f28c9da3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 27 Oct 2011 12:38:22 +0200 Subject: [PATCH 15/40] bprolog support --- include/yap_structs.h | 16 +++++++++ .../dialect/bprolog/fli/{bp.h => bprolog.h} | 35 ++++++++++--------- library/terms.yap | 4 --- 3 files changed, 34 insertions(+), 21 deletions(-) rename library/dialect/bprolog/fli/{bp.h => bprolog.h} (86%) diff --git a/include/yap_structs.h b/include/yap_structs.h index a0996375a..49c9f30db 100644 --- a/include/yap_structs.h +++ b/include/yap_structs.h @@ -95,6 +95,22 @@ typedef double YAP_Float; #endif +typedef enum { + YAP_TAG_ATT = 0x1, + YAP_TAG_UNBOUND = 0x2, + YAP_TAG_REF = 0x4, + YAP_TAG_PAIR = 0x8, + YAP_TAG_ATOM = 0x10, + YAP_TAG_INT = 0x20, + YAP_TAG_LONG_INT = 0x40, + YAP_TAG_BIG_INT = 0x80, + YAP_TAG_RATIONAL = 0x100, + YAP_TAG_FLOAT = 0x200, + YAP_TAG_OPAQUE = 0x400, + YAP_TAG_APPL = 0x800, + YAP_TAG_DBREF = 0x1000 +} YAP_tag_t; + #define YAP_BOOT_FROM_PROLOG 0 #define YAP_BOOT_FROM_SAVED_CODE 1 #define YAP_BOOT_FROM_SAVED_STACKS 2 diff --git a/library/dialect/bprolog/fli/bp.h b/library/dialect/bprolog/fli/bprolog.h similarity index 86% rename from library/dialect/bprolog/fli/bp.h rename to library/dialect/bprolog/fli/bprolog.h index 3ff415ee1..4ee3b7676 100644 --- a/library/dialect/bprolog/fli/bp.h +++ b/library/dialect/bprolog/fli/bprolog.h @@ -1,7 +1,13 @@ #include -#define TERM YAP_Term +typedef YAP_Term TERM; +typedef YAP_Int BPLONG; +typedef YAP_UInt BPULONG; +typedef BPLONG *BPLONG_PTR; + +#define BP_TRUE TRUE +#define BP_FALSE FALSE //extern TERM bp_get_call_arg(int i, int arity); #define bp_get_call_arg( i, arity) YAP_A(i) @@ -19,13 +25,13 @@ #define bp_is_nil(t) YAP_IsTermNil(t) //extern int bp_is_list(TERM t) -#define bp_is_nil(t) YAP_IsPairTerm(t) +#define bp_is_list(t) YAP_IsPairTerm(t) //extern int bp_is_structure(TERM t) -#define bp_is_nil(t) YAP_IsApplTerm(t) +#define bp_is_structure(t) YAP_IsApplTerm(t) //extern int bp_is_compound(TERM t) -#define bp_is_nil(t) ( YAP_IsApplTerm(t) || YAP_IsPairTerm(t) ) +#define bp_is_compound(t) ( YAP_IsApplTerm(t) || YAP_IsPairTerm(t) ) //extern int bp_is_unifiable(TERM t1, Term t2) #define bp_is_unifiable(t1, t2) YAP_unifiable_NOT_IMPLEMENTED(t1, t2) @@ -40,7 +46,7 @@ #define bp_get_float(t) YAP_FloatOfTerm(t) // char *bp_get_name(TERM t) -static inline char * +inline static const char * bp_get_name(TERM t) { if (YAP_IsAtomTerm(t)) { @@ -62,10 +68,10 @@ bp_get_arity(TERM t) return 0; } if (YAP_IsApplTerm(t)) { - return (int)YAP_ArityOfFunctor(YAP_FunctorOfTerm(t))); + return (int)YAP_ArityOfFunctor(YAP_FunctorOfTerm(t)); } // exception = illegal_arguments; - return NULL; + return 0; } //extern int bp_unify(TERM t1, TERM t2) @@ -119,23 +125,18 @@ bp_get_arity(TERM t) // void bp_mount_query_term(TERM goal) // #define bp_mount_query_term(goal) bp_t = t; +TERM bp_t; + // TERM bp_next_solution() static int bp_next_solution(void) { if (bp_t) { - Term t = bp_t; - bp_t = NULL; - return YAP_RunGoal(YAP_ReadBuffer(goal, NULL)); + TERM goal = bp_t; + bp_t = 0L; + return YAP_RunGoal(goal); } return YAP_RestartGoal(); } - - - - - - - diff --git a/library/terms.yap b/library/terms.yap index 67af3f912..0fc3ef41b 100644 --- a/library/terms.yap +++ b/library/terms.yap @@ -38,9 +38,5 @@ term_hash(T,H) :- subsumes_chk(X,Y) :- \+ \+ subsumes(X,Y). -unifiable(X,Y,Z) :- - protected_unifiable(X,Y,Z), !. -unifiable(_,_,_) :- fail. - From 02e39ee78aebfc7b0b6c073ca78c06293414005c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 2 Nov 2011 21:21:28 +0900 Subject: [PATCH 16/40] beautify code. --- C/adtdefs.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/C/adtdefs.c b/C/adtdefs.c index 95adc53ca..9d90b7351 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -115,7 +115,7 @@ SearchInInvisible(char *atom) READ_LOCK(INVISIBLECHAIN.AERWLock); chain = RepAtom(INVISIBLECHAIN.Entry); - while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom) != 0) { + while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom)) { chain = RepAtom(chain->NextOfAE); } READ_UNLOCK(INVISIBLECHAIN.AERWLock); From 6ed7736c28f61cd87a4bd96fbdc5417c48a1e73c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:44:08 +0900 Subject: [PATCH 17/40] C implementation of numbervars --- C/utilpreds.c | 528 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 521 insertions(+), 7 deletions(-) diff --git a/C/utilpreds.c b/C/utilpreds.c index 1cb9bf4c7..981c81eb7 100644 --- a/C/utilpreds.c +++ b/C/utilpreds.c @@ -1836,7 +1836,7 @@ static Term vars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Ter } static int -expand_vts( USES_REGS1 ) +expand_vts( int args USES_REGS ) { UInt expand = LOCAL_Error_Size; yap_error_number yap_errno = LOCAL_Error_TYPE; @@ -1913,7 +1913,7 @@ p_variables_in_term( USES_REGS1 ) /* variables in term t */ ArityOfFunctor(f), ARG2 PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -1948,7 +1948,7 @@ p_term_variables( USES_REGS1 ) /* variables in term t */ ArityOfFunctor(f), TermNil PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -2168,7 +2168,7 @@ p_term_attvars( USES_REGS1 ) /* variables in term t */ ArityOfFunctor(f), TermNil PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -2201,7 +2201,7 @@ p_term_variables3( USES_REGS1 ) /* variables in term t */ ArityOfFunctor(f), ARG3 PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -2401,7 +2401,7 @@ p_variables_within_term( USES_REGS1 ) /* variables within term t */ ArityOfFunctor(f), Deref(ARG1) PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -2606,7 +2606,7 @@ p_new_variables_in_term( USES_REGS1 ) /* variables within term t */ ArityOfFunctor(f), Deref(ARG1) PASS_REGS); } if (out == 0L) { - if (!expand_vts( PASS_REGS1 )) + if (!expand_vts( 3 PASS_REGS )) return FALSE; } } while (out == 0L); @@ -4210,8 +4210,520 @@ p_is_list( USES_REGS1 ) return Yap_IsListTerm(Deref(ARG1)); } +static Term +numbervar(Int id) +{ + Term ts[1]; + ts[0] = MkIntegerTerm(id); + return Yap_MkApplTerm(FunctorVar, 1, ts); +} +static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Int numbv USES_REGS) +{ + + register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace(); + register tr_fr_ptr TR0 = TR; + CELL *InitialH = H; + + to_visit0 = to_visit; + loop: + while (pt0 < pt0_end) { + register CELL d0; + register CELL *ptd0; + ++ pt0; + ptd0 = pt0; + d0 = *ptd0; + deref_head(d0, vars_in_term_unk); + vars_in_term_nvar: + { + if (IsPairTerm(d0)) { + if (to_visit + 1024 >= (CELL **)AuxSp) { + goto aux_overflow; + } +#ifdef RATIONAL_TREES + to_visit[0] = pt0; + to_visit[1] = pt0_end; + to_visit[2] = (CELL *)*pt0; + to_visit += 3; + *pt0 = TermNil; +#else + if (pt0 < pt0_end) { + to_visit[0] = pt0; + to_visit[1] = pt0_end; + to_visit += 2; + } +#endif + pt0 = RepPair(d0) - 1; + pt0_end = RepPair(d0) + 1; + } else if (IsApplTerm(d0)) { + register Functor f; + register CELL *ap2; + /* store the terms to visit */ + ap2 = RepAppl(d0); + f = (Functor)(*ap2); + if (IsExtensionFunctor(f)) { + continue; + } + /* store the terms to visit */ + if (to_visit + 1024 >= (CELL **)AuxSp) { + goto aux_overflow; + } +#ifdef RATIONAL_TREES + to_visit[0] = pt0; + to_visit[1] = pt0_end; + to_visit[2] = (CELL *)*pt0; + to_visit += 3; + *pt0 = TermNil; +#else + if (pt0 < pt0_end) { + to_visit[0] = pt0; + to_visit[1] = pt0_end; + to_visit += 2; + } +#endif + d0 = ArityOfFunctor(f); + pt0 = ap2; + pt0_end = ap2 + d0; + } + continue; + } + + + derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar); + /* do or pt2 are unbound */ + *ptd0 = numbervar(numbv++); + /* leave an empty slot to fill in later */ + if (H+1024 > ASP) { + goto global_overflow; + } + /* next make sure noone will see this as a variable again */ + if (TR > (tr_fr_ptr)LOCAL_TrailTop - 256) { + /* Trail overflow */ + if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) { + goto trail_overflow; + } + } + TrailTerm(TR++) = (CELL)ptd0; + } + /* Do we still have compound terms to visit */ + if (to_visit > to_visit0) { +#ifdef RATIONAL_TREES + to_visit -= 3; + pt0 = to_visit[0]; + pt0_end = to_visit[1]; + *pt0 = (CELL)to_visit[2]; +#else + to_visit -= 2; + pt0 = to_visit[0]; + pt0_end = to_visit[1]; +#endif + goto loop; + } + + Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0); + return numbv; + + trail_overflow: +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit -= 3; + pt0 = to_visit[0]; + *pt0 = (CELL)to_visit[2]; + } +#endif + LOCAL_Error_TYPE = OUT_OF_TRAIL_ERROR; + LOCAL_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *); + clean_tr(TR0 PASS_REGS); + Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0); + H = InitialH; + return -1; + + aux_overflow: + LOCAL_Error_Size = (to_visit-to_visit0)*sizeof(CELL **); +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit -= 3; + pt0 = to_visit[0]; + *pt0 = (CELL)to_visit[2]; + } +#endif + LOCAL_Error_TYPE = OUT_OF_AUXSPACE_ERROR; + clean_tr(TR0 PASS_REGS); + Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0); + H = InitialH; + return -1; + + global_overflow: +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit -= 3; + pt0 = to_visit[0]; + *pt0 = (CELL)to_visit[2]; + } +#endif + clean_tr(TR0 PASS_REGS); + Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0); + H = InitialH; + LOCAL_Error_TYPE = OUT_OF_STACK_ERROR; + LOCAL_Error_Size = (ASP-H)*sizeof(CELL); + return -1; + +} + +Int +Yap_NumberVars( Term inp, Int numbv ) /* numbervariables in term t */ +{ + CACHE_REGS + Int out; + Term t; + + restart: + t = Deref(inp); + if (IsVarTerm(t)) { + CELL *ptd0 = VarOfTerm(t); + *ptd0 = numbervar(numbv); + TrailTerm(TR++) = (CELL)ptd0; + return numbv+1; + } else if (IsPrimitiveTerm(t)) { + return numbv; + } else if (IsPairTerm(t)) { + out = numbervars_in_complex_term(RepPair(t)-1, + RepPair(t)+1, numbv PASS_REGS); + } else { + Functor f = FunctorOfTerm(t); + + out = numbervars_in_complex_term(RepAppl(t), + RepAppl(t)+ + ArityOfFunctor(f), numbv PASS_REGS); + } + if (out < 0) { + if (!expand_vts( 3 PASS_REGS )) + return FALSE; + goto restart; + } + return out; +} + +static Int +p_numbervars(void) +{ + Term t2 = Deref(ARG2); + Int out; + + if (IsVarTerm(t2)) { + Yap_Error(INSTANTIATION_ERROR,t2,"numbervars/3"); + return FALSE; + } + if (!IsIntegerTerm(t2)) { + Yap_Error(TYPE_ERROR_INTEGER,t2,"term_hash/4"); + return(FALSE); + } + if ((out = Yap_NumberVars(ARG1, IntegerOfTerm(t2))) < 0) + return FALSE; + return Yap_unify(ARG3, MkIntegerTerm(out)); +} + +static int +unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) +{ + + struct cp_frame *to_visit0, *to_visit = (struct cp_frame *)Yap_PreAllocCodeSpace(); + CELL *HB0 = HB; + tr_fr_ptr TR0 = TR; + int ground = TRUE; + Int max = -1; + + HB = HLow; + to_visit0 = to_visit; + loop: + while (pt0 < pt0_end) { + register CELL d0; + register CELL *ptd0; + ++ pt0; + ptd0 = pt0; + d0 = *ptd0; + deref_head(d0, unnumber_term_unk); + unnumber_term_nvar: + { + if (IsPairTerm(d0)) { + CELL *ap2 = RepPair(d0); + if (ap2 >= HB && ap2 < H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + *ptf = AbsPair(H); + ptf++; +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct cp_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + /* fool the system into thinking we had a variable there */ + *pt0 = AbsPair(H); + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct cp_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + ground = TRUE; + pt0 = ap2 - 1; + pt0_end = ap2 + 1; + ptf = H; + H += 2; + if (H > ASP - 2048) { + goto overflow; + } + } else if (IsApplTerm(d0)) { + register Functor f; + register CELL *ap2; + /* store the terms to visit */ + ap2 = RepAppl(d0); + if (ap2 >= HB && ap2 <= H) { + /* If this is newer than the current term, just reuse */ + *ptf++ = d0; + continue; + } + f = (Functor)(*ap2); + + if (IsExtensionFunctor(f)) { + *ptf++ = d0; /* you can just unnumber other extensions. */ + continue; + } + if (f == FunctorVar) { + Int id = IntegerOfTerm(ap2[1]); + ground = FALSE; + if (id < -1) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, "unnumber vars cannot cope with VAR(-%d)", id); + return 0L; + } + if (id <= max) { + if (ASP-(max+1) <= H) { + goto overflow; + } + /* we found this before */ + *ptf++ = ASP[-id-1]; + continue; + } + max = id; + if (ASP-(max+1) <= H) { + goto overflow; + } + /* new variable */ + RESET_VARIABLE(ptf); + ASP[-id-1] = (CELL)ptf; + ptf++; + continue; + } + *ptf = AbsAppl(H); + ptf++; + /* store the terms to visit */ +#ifdef RATIONAL_TREES + if (to_visit+1 >= (struct cp_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->oldv = *pt0; + to_visit->ground = ground; + /* fool the system into thinking we had a variable there */ + *pt0 = AbsAppl(H); + to_visit ++; +#else + if (pt0 < pt0_end) { + if (to_visit+1 >= (struct cp_frame *)AuxSp) { + goto heap_overflow; + } + to_visit->start_cp = pt0; + to_visit->end_cp = pt0_end; + to_visit->to = ptf; + to_visit->ground = ground; + to_visit ++; + } +#endif + ground = (f != FunctorMutable); + d0 = ArityOfFunctor(f); + pt0 = ap2; + pt0_end = ap2 + d0; + /* store the functor for the new term */ + H[0] = (CELL)f; + ptf = H+1; + H += 1+d0; + if (H > ASP - 2048) { + goto overflow; + } + } else { + /* just unnumber atoms or integers */ + *ptf++ = d0; + } + continue; + } + + derefa_body(d0, ptd0, unnumber_term_unk, unnumber_term_nvar); + ground = FALSE; + *ptf++ = (CELL) ptd0; + } + /* Do we still have compound terms to visit */ + if (to_visit > to_visit0) { + to_visit --; + if (ground) { + CELL old = to_visit->oldv; + CELL *newp = to_visit->to-1; + CELL new = *newp; + + *newp = old; + if (IsApplTerm(new)) + H = RepAppl(new); + else + H = RepPair(new); + } + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; +#ifdef RATIONAL_TREES + *pt0 = to_visit->oldv; +#endif + ground = (ground && to_visit->ground); + goto loop; + } + + /* restore our nice, friendly, term to its original state */ + clean_dirty_tr(TR0 PASS_REGS); + HB = HB0; + return ground; + + overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + /* follow chain of multi-assigned variables */ + return -1; + + heap_overflow: + /* oops, we're in trouble */ + H = HLow; + /* we've done it */ + /* restore our nice, friendly, term to its original state */ + HB = HB0; +#ifdef RATIONAL_TREES + while (to_visit > to_visit0) { + to_visit --; + pt0 = to_visit->start_cp; + pt0_end = to_visit->end_cp; + ptf = to_visit->to; + *pt0 = to_visit->oldv; + } +#endif + reset_trail(TR0); + LOCAL_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0; + return -3; +} + + +static Term +UnnumberTerm(Term inp, UInt arity USES_REGS) { + Term t = Deref(inp); + tr_fr_ptr TR0 = TR; + + if (IsVarTerm(t)) { + return inp; + } else if (IsPrimitiveTerm(t)) { + return t; + } else if (IsPairTerm(t)) { + Term tf; + CELL *ap; + CELL *Hi; + + restart_list: + ap = RepPair(t); + Hi = H; + tf = AbsPair(H); + H += 2; + { + int res; + if ((res = unnumber_complex_term(ap-1, ap+1, Hi, Hi PASS_REGS)) < 0) { + H = Hi; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_list; + } else if (res) { + H = Hi; + return t; + } + } + return tf; + } else { + Functor f = FunctorOfTerm(t); + Term tf; + CELL *HB0; + CELL *ap; + + restart_appl: + f = FunctorOfTerm(t); + HB0 = H; + ap = RepAppl(t); + tf = AbsAppl(H); + H[0] = (CELL)f; + H += 1+ArityOfFunctor(f); + if (H > ASP-128) { + H = HB0; + if ((t = handle_cp_overflow(-1, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else { + int res; + + if ((res = unnumber_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0 PASS_REGS)) < 0) { + H = HB0; + if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) + return FALSE; + goto restart_appl; + } else if (res && FunctorOfTerm(t) != FunctorMutable) { + H = HB0; + return t; + } + } + return tf; + } +} + +Term +Yap_UnNumberTerm(Term inp) { + CACHE_REGS + return UnnumberTerm(inp, 0 PASS_REGS); +} + +static int +p_unnumbervars(void) { + return Yap_unify(Yap_UnNumberTerm(ARG1), ARG2); +} + void Yap_InitUtilCPreds(void) { CACHE_REGS @@ -4233,6 +4745,8 @@ void Yap_InitUtilCPreds(void) Yap_InitCPred("import_term", 1, p_import_term, 0); Yap_InitCPred("export_term", 1, p_export_term, 0); #endif + Yap_InitCPred("numbervars", 3, p_numbervars, 0); + Yap_InitCPred("unnumbervars", 2, p_unnumbervars, 0); CurrentModule = TERMS_MODULE; Yap_InitCPred("variable_in_term", 2, p_var_in_term, 0); Yap_InitCPred("term_hash", 4, p_term_hash, 0); From 73e3359d4fcfb246b29b954d024e05ab61567a96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:44:38 +0900 Subject: [PATCH 18/40] enumerate bhashes and fix bug in haash expansion. --- library/bhash.yap | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/library/bhash.yap b/library/bhash.yap index 8049f22f3..46893bfbe 100644 --- a/library/bhash.yap +++ b/library/bhash.yap @@ -1,3 +1,5 @@ +%% -*- Prolog -*- + /* This code implements hash-arrays. @@ -33,7 +35,7 @@ It relies on dynamic array code. array_default_size(2048). -is_b_hash(V) :- !, fail. +is_b_hash(V) :- var(V), !, fail. is_b_hash(hash(_,_,_,_,_)). b_hash_new(hash(Keys, Vals, Size, N, _, _)) :- @@ -133,17 +135,29 @@ add_element(Keys, Index, Size, N, Vals, Key, NewVal, Hash, NewHash) :- get_mutable(NEls, N), NN is NEls+1, update_mutable(NN, N), + array_element(Keys, Index, Key), + update_mutable(NN, N), + array_element(Vals, Index, Mutable), + create_mutable(NewVal, Mutable), ( NN > Size/3 -> expand_array(Hash, NewHash) ; Hash = NewHash - ), - array_element(Keys, Index, Key), - update_mutable(NN, N), - array_element(Vals, Index, Mutable), - create_mutable(NewVal, Mutable). + ). + +expand_array(Hash, NewHash) :- + Hash == NewHash, !, + Hash = hash(Keys, Vals, Size, _X, F, _CmpF), + new_size(Size, NewSize), + array(NewKeys, NewSize), + array(NewVals, NewSize), + copy_hash_table(Size, Keys, Vals, F, NewSize, NewKeys, NewVals), + /* overwrite in place */ + setarg(1, Hash, NewKeys), + setarg(2, Hash, NewVals), + setarg(3, Hash, NewSize). expand_array(Hash, hash(NewKeys, NewVals, NewSize, X, F, CmpF)) :- Hash = hash(Keys, Vals, Size, X, F, CmpF), @@ -200,17 +214,17 @@ cmp_f(F, A, B) :- call(F, A, B). b_hash_to_list(hash(Keys, Vals, _, _, _, _), LKeyVals) :- - Keys =.. LKs, - Vals =.. LVs, + Keys =.. (_.LKs), + Vals =.. (_.LVs), mklistpairs(LKs, LVs, LKeyVals). b_hash_keys_to_list(hash(Keys, _, _, _, _, _), LKeys) :- - Keys =.. LKs, + Keys =.. (_.LKs), mklistels(LKs, LKeys). -b_hash_keys_to_list(hash(_, Vals, _, _, _, _), LVals) :- - Vals =.. LVs, - mklisvals(LVs, LVals). +b_hash_values_to_list(hash(_, Vals, _, _, _, _), LVals) :- + Vals =.. (_.LVs), + mklistvals(LVs, LVals). mklistpairs([], [], []). mklistpairs(V.LKs, _.LVs, KeyVals) :- var(V), !, @@ -220,14 +234,14 @@ mklistpairs(K.LKs, V.LVs, (K-VV).KeyVals) :- mklistpairs(LKs, LVs, KeyVals). mklistels([], []). -mklistels(V.Es, NEls) :- var(V), !, - mklistels(Els, Nels). +mklistels(V.Els, NEls) :- var(V), !, + mklistels(Els, NEls). mklistels(K.Els, K.NEls) :- mklistels(Els, NEls). mklistvals([], []). -mklistvals(V.Es, NVals) :- var(V), !, - mklistvals(Vals, Nvals). +mklistvals(V.Vals, NVals) :- var(V), !, + mklistvals(Vals, NVals). mklistvals(K.Vals, KK.NVals) :- get_mutable(KK, K), mklistvals(Vals, NVals). From 3966822bff6f58eb04abe9d4dc4963806be3b8bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:45:02 +0900 Subject: [PATCH 19/40] Setting YREG in cut_t seems buggy. --- C/absmi.c | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/C/absmi.c b/C/absmi.c index 55358914a..538d9ec38 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -2267,23 +2267,6 @@ Yap_absmi(int inp) prune((choiceptr)YREG[E_CB]); setregs(); PREG = NEXTOP(NEXTOP(NEXTOP(PREG, s),Osbpp),l); -#ifdef FROZEN_STACKS - { - choiceptr top_b = PROTECT_FROZEN_B(B); -#ifdef YAPOR_SBA - if (ENV > (CELL *) top_b || ENV < H) YREG = (CELL *) top_b; -#else - if (ENV > (CELL *) top_b) YREG = (CELL *) top_b; -#endif /* YAPOR_SBA */ - else YREG = (CELL *)((CELL)ENV + ENV_Size(CPREG)); - } -#else - if (ENV > (CELL *)B) { - YREG = (CELL *)B; - } else { - YREG = (CELL *) ((CELL) ENV + ENV_Size(CPREG)); - } -#endif GONext(); ENDOp(); From 51bcb1f5a3610918f1af3e98649006aa0d4f5e16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:45:51 +0900 Subject: [PATCH 20/40] handle PL_unify_int64 without bigint when number is small enough. --- library/dialect/swi/fli/swi.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index 13086d5bb..9adf1632b 100644 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -931,7 +931,10 @@ X_API int PL_put_integer(term_t t, long n) X_API int PL_put_int64(term_t t, int64_t n) { CACHE_REGS -#if USE_GMP +#if SIZEOF_INT_P==8 + Yap_PutInSlot(t,MkIntegerTerm(n)); + return TRUE; +#elif USE_GMP char s[64]; MP_INT rop; @@ -1176,6 +1179,8 @@ X_API int PL_unify_int64(term_t t, int64_t n) iterm = YAP_MkBigNumTerm((void *)&rop); return YAP_Unify(Yap_GetFromSlot(t PASS_REGS),iterm); #else + if ((long)n == n) + return PL_unify_integer(t, n); fprintf(stderr,"Error in PL_unify_int64: please install GMP\n"); return FALSE; #endif From 836a6ee6a4d939b547e5531c43232a154e4f1b1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:46:52 +0900 Subject: [PATCH 21/40] make it possible to access Regs and Tag codes from external sources. --- include/YapRegs.h | 28 +++++++++++ include/YapTags.h | 119 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+) create mode 100644 include/YapRegs.h create mode 100644 include/YapTags.h diff --git a/include/YapRegs.h b/include/YapRegs.h new file mode 100644 index 000000000..1c79064ec --- /dev/null +++ b/include/YapRegs.h @@ -0,0 +1,28 @@ +#ifndef YAP_REGS_H + +#define YAP_REGS_H 1 + +#if defined(TABLING) || defined(YAPOR_SBA) +typedef struct trail_frame { + Term term; + CELL value; +} *tr_fr_ptr; + +#define TrailTerm(X) ((X)->term) +#else +typedef Term *tr_fr_ptr; + +#define TrailTerm(X) ((X)->term) +#endif + +typedef void *choiceptr; + +typedef void *yamop; + +typedef char *ADDR; + +#define RESET_VARIABLE(X) (*(X) = (CELL)(X)) + +#include "src/Regs.h" + +#endif diff --git a/include/YapTags.h b/include/YapTags.h new file mode 100644 index 000000000..587900b54 --- /dev/null +++ b/include/YapTags.h @@ -0,0 +1,119 @@ +/***********************************************************************/ + + /* + absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var + + with AbsAppl(t) : *CELL -> Term + and RepAppl(t) : Term -> *CELL + + and AbsPair(t) : *CELL -> Term + and RepPair(t) : Term -> *CELL + + and IsIntTerm(t) = ... + and IsAtomTerm(t) = ... + and IsVarTerm(t) = ... + and IsPairTerm(t) = ... + and IsApplTerm(t) = ... + and IsFloatTerm(t) = ... + and IsRefTerm(t) = ... + and IsNonVarTerm(t) = ! IsVar(t) + and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t) + and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t) + and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t) + + and MkIntTerm(n) = ... + and MkFloatTerm(f) = ... + and MkAtomTerm(a) = ... + and MkVarTerm(r) = ... + and MkApplTerm(f,n,args) = ... + and MkPairTerm(hd,tl) = ... + and MkRefTerm(R) = ... + + and PtrOfTerm(t) : Term -> CELL * = ... + and IntOfTerm(t) : Term -> int = ... + and FloatOfTerm(t) : Term -> flt = ... + and AtomOfTerm(t) : Term -> Atom = ... + and VarOfTerm(t) : Term -> *Term = .... + and HeadOfTerm(t) : Term -> Term = ... + and TailOfTerm(t) : Term -> Term = ... + and FunctorOfTerm(t) : Term -> Functor = ... + and ArgOfTerm(i,t) : Term -> Term= ... + and RefOfTerm(t) : Term -> DBRef = ... + + */ + +/* + YAP can use several different tag schemes, according to the kind of + machine we are experimenting with. +*/ + +#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME) + +#include "Tags_32bits.h" + +#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */ + +/* AIX will by default place mmaped segments at 0x30000000. This is + incompatible with the high tag scheme. Linux-ELF also does not like + if you place things in the lower addresses (power to the libc people). +*/ + +#if defined(__APPLE__) +/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */ +#undef USE_DL_MALLOC +#ifndef USE_SYSTEM_MALLOC +#define USE_SYSTEM_MALLOC 1 +#endif +#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__) +#define USE_LOW32_TAGS 1 +#endif + +#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) + +#include "Tags_32Ops.h" + +#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */ + +#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS) + +#include "Tags_32LowTag.h" + +#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */ + +#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) + +#include "Tags_64bits.h" + +#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */ + +#if !LONG_ADDRESSES + +#include "Tags_24bits.h" + +#endif /* !LONG_ADDRESSES */ + +#ifdef TAG_LOW_BITS_32 + +#if !GC_NO_TAGS +#define MBIT 0x80000000 +#define RBIT 0x40000000 + +#if IN_SECOND_QUADRANT +#define INVERT_RBIT 1 /* RBIT is 1 by default */ +#endif +#endif /* !GC_NO_TAGS */ + +#else + +#if !GC_NO_TAGS +#if defined(YAPOR_SBA) && defined(__linux__) +#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */ +#else +#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */ +#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */ +#endif +#endif /* !GC_NO_TAGS */ + +#endif + +#define TermSize sizeof(Term) From d2c50b72c6d2e0eef2def4dfbe90f3a3bc253010 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:48:37 +0900 Subject: [PATCH 22/40] should be in main H directory. --- H/YapTags.h | 398 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 398 insertions(+) create mode 100644 H/YapTags.h diff --git a/H/YapTags.h b/H/YapTags.h new file mode 100644 index 000000000..f99a6d201 --- /dev/null +++ b/H/YapTags.h @@ -0,0 +1,398 @@ +/************************************************************************* +* * +* YAP Prolog %W% %G% * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * +* * +************************************************************************** +* * +* File: YapTags.h * +* mods: * +* comments: Term Operations for YAP * +* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ * +*************************************************************************/ + +#ifndef EXTERN +#define EXTERN extern +#endif + +#ifndef SHORT_ADDRESSES +# define LONG_ADDRESSES 1 +#else +# define LONG_ADDRESSES 0 +#endif + +/***********************************************************************/ + + /* + absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var + + with AbsAppl(t) : *CELL -> Term + and RepAppl(t) : Term -> *CELL + + and AbsPair(t) : *CELL -> Term + and RepPair(t) : Term -> *CELL + + and IsIntTerm(t) = ... + and IsAtomTerm(t) = ... + and IsVarTerm(t) = ... + and IsPairTerm(t) = ... + and IsApplTerm(t) = ... + and IsFloatTerm(t) = ... + and IsRefTerm(t) = ... + and IsNonVarTerm(t) = ! IsVar(t) + and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t) + and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t) + and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t) + + and MkIntTerm(n) = ... + and MkFloatTerm(f) = ... + and MkAtomTerm(a) = ... + and MkVarTerm(r) = ... + and MkApplTerm(f,n,args) = ... + and MkPairTerm(hd,tl) = ... + and MkRefTerm(R) = ... + + and PtrOfTerm(t) : Term -> CELL * = ... + and IntOfTerm(t) : Term -> int = ... + and FloatOfTerm(t) : Term -> flt = ... + and AtomOfTerm(t) : Term -> Atom = ... + and VarOfTerm(t) : Term -> *Term = .... + and HeadOfTerm(t) : Term -> Term = ... + and TailOfTerm(t) : Term -> Term = ... + and FunctorOfTerm(t) : Term -> Functor = ... + and ArgOfTerm(i,t) : Term -> Term= ... + and RefOfTerm(t) : Term -> DBRef = ... + + */ + +/* + YAP can use several different tag schemes, according to the kind of + machine we are experimenting with. +*/ + +#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME) + +#include "Tags_32bits.h" + +#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */ + +/* AIX will by default place mmaped segments at 0x30000000. This is + incompatible with the high tag scheme. Linux-ELF also does not like + if you place things in the lower addresses (power to the libc people). +*/ + +#if defined(__APPLE__) +/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */ +#undef USE_DL_MALLOC +#ifndef USE_SYSTEM_MALLOC +#define USE_SYSTEM_MALLOC 1 +#endif +#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__) +#define USE_LOW32_TAGS 1 +#endif + +#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) + +#include "Tags_32Ops.h" + +#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */ + +#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS) + +#include "Tags_32LowTag.h" + +#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */ + +#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) + +#include "Tags_64bits.h" + +#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */ + +#if !LONG_ADDRESSES + +#include "Tags_24bits.h" + +#endif /* !LONG_ADDRESSES */ + +#ifdef TAG_LOW_BITS_32 + +#if !GC_NO_TAGS +#define MBIT 0x80000000 +#define RBIT 0x40000000 + +#if IN_SECOND_QUADRANT +#define INVERT_RBIT 1 /* RBIT is 1 by default */ +#endif +#endif /* !GC_NO_TAGS */ + +#else + +#if !GC_NO_TAGS +#if defined(YAPOR_SBA) && defined(__linux__) +#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */ +#else +#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */ +#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */ +#endif +#endif /* !GC_NO_TAGS */ + +#endif + +/************************************************************************************************* + ??? +*************************************************************************************************/ + +#define MkVarTerm() MkVarTerm__( PASS_REGS1 ) +#define MkPairTerm(A,B) MkPairTerm__( A, B PASS_REGS ) + +/************************************************************************************************* + applies to unbound variables +*************************************************************************************************/ + +inline EXTERN Term *VarOfTerm (Term t); + +inline EXTERN Term * +VarOfTerm (Term t) +{ + return (Term *) (t); +} + + +#ifdef YAPOR_SBA + +inline EXTERN Term MkVarTerm__ ( USES_REGS1 ); + +inline EXTERN Term +MkVarTerm__ ( USES_REGS1 ) +{ + return (Term) ((*H = 0, H++)); +} + + + +inline EXTERN int IsUnboundVar (Term *); + +inline EXTERN int +IsUnboundVar (Term * t) +{ + return (int) (*(t) == 0); +} + + +#else + +#ifdef _YAP_NOT_INSTALLED_ + +inline EXTERN Term MkVarTerm__ ( USES_REGS1 ); + +inline EXTERN Term +MkVarTerm__ ( USES_REGS1 ) +{ + return (Term) ((*H = (CELL) H, H++)); +} + +#endif + + +inline EXTERN int IsUnboundVar (Term *); + +inline EXTERN int +IsUnboundVar (Term * t) +{ + return (int) (*(t) == (Term) (t)); +} + + +#endif + +inline EXTERN CELL *PtrOfTerm (Term); + +inline EXTERN CELL * +PtrOfTerm (Term t) +{ + return (CELL *) (*(CELL *) (t)); +} + + + + +inline EXTERN Functor FunctorOfTerm (Term); + +inline EXTERN Functor +FunctorOfTerm (Term t) +{ + return (Functor) (*RepAppl (t)); +} + + +#if USE_LOW32_TAGS + +inline EXTERN Term MkAtomTerm (Atom); + +inline EXTERN Term +MkAtomTerm (Atom a) +{ + return (Term) (AtomTag | (CELL) (a)); +} + + + +inline EXTERN Atom AtomOfTerm (Term t); + +inline EXTERN Atom +AtomOfTerm (Term t) +{ + return (Atom) ((~AtomTag & (CELL) (t))); +} + + +#else + +inline EXTERN Term MkAtomTerm (Atom); + +inline EXTERN Term +MkAtomTerm (Atom a) +{ + return (Term) (TAGGEDA ((CELL)AtomTag, (CELL) (a))); +} + + + +inline EXTERN Atom AtomOfTerm (Term t); + +inline EXTERN Atom +AtomOfTerm (Term t) +{ + return (Atom) (NonTagPart (t)); +} + + +#endif + +inline EXTERN int IsAtomTerm (Term); + +inline EXTERN int +IsAtomTerm (Term t) +{ + return (int) (CHKTAG ((t), AtomTag)); +} + + + + +inline EXTERN Term MkIntTerm (Int); + +inline EXTERN Term +MkIntTerm (Int n) +{ + return (Term) (TAGGED (NumberTag, (n))); +} + + +/* + A constant to subtract or add to a well-known term, we assume no + overflow problems are possible +*/ + +inline EXTERN Term MkIntConstant (Int); + +inline EXTERN Term +MkIntConstant (Int n) +{ + return (Term) (NONTAGGED (NumberTag, (n))); +} + + + +inline EXTERN int IsIntTerm (Term); + +inline EXTERN int +IsIntTerm (Term t) +{ + return (int) (CHKTAG ((t), NumberTag)); +} + + +#ifdef _YAP_NOT_INSTALLED_ +EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) ); + +EXTERN inline Term +MkPairTerm__ (Term head, Term tail USES_REGS) +{ + register CELL *p = H; + + H[0] = head; + H[1] = tail; + H += 2; + return (AbsPair (p)); +} + +#endif + + +/* Needed to handle numbers: + these two macros are fundamental in the integer/float conversions */ + +#ifdef M_WILLIAMS +#define IntInBnd(X) (TRUE) +#else +#ifdef TAGS_FAST_OPS +#define IntInBnd(X) (Unsigned( ( (Int)(X) >> (32-7) ) + 1) <= 1) +#else +#define IntInBnd(X) ( (X) < MAX_ABS_INT && \ + (X) > -MAX_ABS_INT-1L ) +#endif +#endif +#ifdef C_PROLOG +#define FlIsInt(X) ( (X) == (Int)(X) && IntInBnd((X)) ) +#else +#define FlIsInt(X) ( FALSE ) +#endif + + +/* + There are two types of functors: + + o Special functors mark special terms + on the heap that should be seen as constants. + + o Standard functors mark normal applications. + +*/ + +#include "TermExt.h" + +#define IsAccessFunc(func) ((func) == FunctorAccess) + +#ifdef _YAP_NOT_INSTALLED_ +inline EXTERN Term MkIntegerTerm (Int); + +inline EXTERN Term +MkIntegerTerm (Int n) +{ + return (Term) (IntInBnd (n) ? MkIntTerm (n) : MkLongIntTerm (n)); +} +#endif + + +inline EXTERN int IsIntegerTerm (Term); + +inline EXTERN int +IsIntegerTerm (Term t) +{ + return (int) (IsIntTerm (t) || IsLongIntTerm (t)); +} + +inline EXTERN Int IntegerOfTerm (Term); + +inline EXTERN Int +IntegerOfTerm (Term t) +{ + + return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t)); +} + + From d690ffdb1880b59d5a00b2b78c8175545cfcdd32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:49:06 +0900 Subject: [PATCH 23/40] make ground.yap use new C-code. --- pl/ground.yap | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pl/ground.yap b/pl/ground.yap index 2f1a18be1..f3ef2b2db 100644 --- a/pl/ground.yap +++ b/pl/ground.yap @@ -48,8 +48,6 @@ ground(Term) :- ground(ArgN), '$ground'(M, Term). -*/ - numbervars(Term, M, N) :- '$variables_in_term'(Term, [], L), '$numbermarked_vars'(L, M, N). @@ -62,3 +60,5 @@ numbervars(Term, M, N) :- M1 is M+1, '$numbermarked_vars'(L, M1, N). +*/ + From 98de12268711a1418f0e78d167dc5ec086127373 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:49:41 +0900 Subject: [PATCH 24/40] UserCCode shouldn't be allowed to look up hidden atoms. --- C/init.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/C/init.c b/C/init.c index 6f1c69559..8a09598d2 100644 --- a/C/init.c +++ b/C/init.c @@ -409,7 +409,10 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, UInt flags) Functor f = NULL; while (atom == NIL) { - atom = Yap_FullLookupAtom(Name); + if (flags & UserCPredFlag) + atom = Yap_LookupAtom(Name); + else + atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while initialising %s", Name); return; From 0154db015e24bf4f2bc741eab7faa3780d23f860 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:50:34 +0900 Subject: [PATCH 25/40] beautification. --- C/unify.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/C/unify.c b/C/unify.c index 86991f907..0a0841e22 100644 --- a/C/unify.c +++ b/C/unify.c @@ -932,11 +932,11 @@ p_unifiable( USES_REGS1 ) } int -Yap_unifiable( Term d0, Term d1 ) +Yap_Unifiable( Term d0, Term d1 ) { CACHE_REGS tr_fr_ptr trp, trp0 = TR; - Term tf = TermNil; + if (!unifiable(d0,d1)) { return FALSE; } From 780a5ba83eb6aeda2eced07ff74ce0fed53411ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:51:13 +0900 Subject: [PATCH 26/40] use numbervars. --- C/pl-yap.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/C/pl-yap.c b/C/pl-yap.c index fbf1f5a96..378b685c2 100644 --- a/C/pl-yap.c +++ b/C/pl-yap.c @@ -619,7 +619,7 @@ currentOperator(Module m, atom_t name, int kind, int *type, int *priority) int numberVars(term_t t, nv_options *opts, int n ARG_LD) { - return 0; + return Yap_NumberVars(YAP_GetFromSlot(t), n); } /******************************* From c322722d5b7581db5b0bfd014c3fadbadaa86065 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:51:34 +0900 Subject: [PATCH 27/40] add code to call external function by name, it maay come handy one day. --- C/load_dl.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/C/load_dl.c b/C/load_dl.c index 6ee6a4260..fc7583517 100644 --- a/C/load_dl.c +++ b/C/load_dl.c @@ -25,6 +25,28 @@ #include #include +typedef void (*prismf)(void); + +/* only works for dlls */ +int +Yap_CallFunctionByName(const char *thing_string); + +int +Yap_CallFunctionByName(const char *thing_string) +{ + void * handle = dlopen(NULL, RTLD_LAZY | RTLD_NOLOAD); + // you could do RTLD_NOW as well. shouldn't matter + if (!handle) { + CACHE_REGS + Yap_Error(SYSTEM_ERROR, ARG1, "Dynamic linking on main module : %s\n", dlerror()); + } + prismf * addr = (prismf *)dlsym(handle, thing_string); + fprintf(stderr, "%s is at %p\n", thing_string, addr); + if (addr) + (*addr)(); + return TRUE; +} + /* * YAP_FindExecutable(argv[0]) should be called on yap initialization to * locate the executable of Yap From fc2a50b67e5552724cc4ea5b9e777c349b819e6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:51:58 +0900 Subject: [PATCH 28/40] use C-code. --- library/varnumbers.yap | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/library/varnumbers.yap b/library/varnumbers.yap index 32a18b270..a768c9727 100644 --- a/library/varnumbers.yap +++ b/library/varnumbers.yap @@ -31,30 +31,4 @@ max_var_numberl(I0,Ar,T,Max0,Max) :- ). varnumbers(GT, VT) :- - max_var_number(GT,0,Max), - Max1 is Max+1, - functor(Vars,vars,Max1), - varnumbers(GT, Vars, VT). - -varnumbers(V,_,V) :- var(V), !. -varnumbers('$VAR'(I),Vs,V) :- !, - I1 is I+1, - arg(I1,Vs,V). -varnumbers(S,Vs,NS) :- - functor(S,N,Ar), - functor(NS,N,Ar), - varnumbersl(0,Ar,Vs,S,NS). - -varnumbersl(I0,Ar,Vs,S,NS) :- - (I0 =:= Ar -> - true - ; - I is I0+1, - arg(I,S,A), - arg(I,NS,NA), - varnumbers(A,Vs,NA), - varnumbersl(I,Ar,Vs,S,NS) - ). - - - + unnumber_vars(GT, VT). From 9f2b0c7e7096094ac58d56c97c765c149908f464 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:52:52 +0900 Subject: [PATCH 29/40] extend C-interface to support b-prolog like stuff --- C/c_interface.c | 56 +++++++++++++++++++++++++++++++++++++++++- include/YapInterface.h | 14 ++++++++++- 2 files changed, 68 insertions(+), 2 deletions(-) diff --git a/C/c_interface.c b/C/c_interface.c index a60bad24b..59a10d15f 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -384,12 +384,14 @@ X_API Bool STD_PROTO(YAP_IsNonVarTerm,(Term)); X_API Bool STD_PROTO(YAP_IsIntTerm,(Term)); X_API Bool STD_PROTO(YAP_IsLongIntTerm,(Term)); X_API Bool STD_PROTO(YAP_IsBigNumTerm,(Term)); +X_API Bool STD_PROTO(YAP_IsNumberTerm,(Term)); X_API Bool STD_PROTO(YAP_IsRationalTerm,(Term)); X_API Bool STD_PROTO(YAP_IsFloatTerm,(Term)); X_API Bool STD_PROTO(YAP_IsDbRefTerm,(Term)); X_API Bool STD_PROTO(YAP_IsAtomTerm,(Term)); X_API Bool STD_PROTO(YAP_IsPairTerm,(Term)); X_API Bool STD_PROTO(YAP_IsApplTerm,(Term)); +X_API Bool STD_PROTO(YAP_IsCompoundTerm,(Term)); X_API Bool STD_PROTO(YAP_IsExternalDataInStackTerm,(Term)); X_API Bool STD_PROTO(YAP_IsOpaqueObjectTerm,(Term, int)); X_API Term STD_PROTO(YAP_MkIntTerm,(Int)); @@ -427,6 +429,7 @@ X_API void STD_PROTO(YAP_cut_up,(void)); X_API Int STD_PROTO(YAP_Unify,(Term,Term)); X_API int STD_PROTO(YAP_Unifiable,(Term,Term)); X_API int STD_PROTO(YAP_Reset,(void)); +X_API Int STD_PROTO(YAP_ListLength,(Term)); X_API Int STD_PROTO(YAP_Init,(YAP_init_args *)); X_API Int STD_PROTO(YAP_FastInit,(char *)); X_API PredEntry *STD_PROTO(YAP_FunctorToPred,(Functor)); @@ -531,6 +534,9 @@ X_API void *STD_PROTO(YAP_Record,(Term)); X_API Term STD_PROTO(YAP_Recorded,(void *)); X_API int STD_PROTO(YAP_Erase,(void *)); X_API int STD_PROTO(YAP_Variant,(Term, Term)); +X_API Int STD_PROTO(YAP_NumberVars,(Term, Int)); +X_API Term STD_PROTO(YAP_UnNumberVars,(Term)); +X_API int STD_PROTO(YAP_IsNumberedVariable,(Term)); X_API int STD_PROTO(YAP_ExactlyEqual,(Term, Term)); X_API Int STD_PROTO(YAP_TermHash,(Term, Int, Int, int)); X_API void STD_PROTO(YAP_signal,(int)); @@ -603,6 +609,12 @@ YAP_IsIntTerm(Term t) return IsIntegerTerm(t); } +X_API Bool +YAP_IsNumberTerm(Term t) +{ + return IsIntegerTerm(t) || IsIntTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t); +} + X_API Bool YAP_IsLongIntTerm(Term t) { @@ -683,6 +695,13 @@ YAP_IsApplTerm(Term t) return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t))); } +X_API Bool +YAP_IsCompoundTerm(Term t) +{ + return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t))) || + IsPairTerm(t); +} + X_API Term YAP_MkIntTerm(Int n) @@ -1188,7 +1207,7 @@ YAP_Unifiable(Term t1, Term t2) int out; BACKUP_MACHINE_REGS(); - out = Yap_unifiable(t1, t2); + out = Yap_Unifiable(t1, t2); RECOVER_MACHINE_REGS(); return out; @@ -3854,3 +3873,38 @@ YAP_TagOfTerm(Term t) return YAP_TAG_APPL; } } + +int YAP_BPROLOG_exception; +Term YAP_BPROLOG_curr_toam_status; + +Int +YAP_ListLength(Term t) { + Int l = 0; + while (TRUE) { + if (IsVarTerm(t)) return -1; + if (t == TermNil) + return l; + if (!IsPairTerm(t)) + return -1; + l++; + t = TailOfTerm(t); + } +} + +Int +YAP_NumberVars(Term t, Int nbv) { + return Yap_NumberVars(t, nbv); +} + +Term +YAP_UnNumberVars(Term t) { + return Yap_UnNumberTerm(t); +} + +int +YAP_IsNumberedVariable(Term t) { + return IsApplTerm(t) && + FunctorOfTerm(t) == FunctorVar && + IsIntegerTerm(ArgOfTerm(1,t)); +} + diff --git a/include/YapInterface.h b/include/YapInterface.h index cc6986bdb..ebb20ff53 100644 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -109,6 +109,9 @@ extern X_API YAP_Bool PROTO(YAP_IsRationalTerm,(YAP_Term)); /* YAP_Bool IsFloatTerm(YAP_Term) */ extern X_API YAP_Bool PROTO(YAP_IsFloatTerm,(YAP_Term)); +/* YAP_Bool IsNumberTerm(YAP_Term) */ +extern X_API YAP_Bool PROTO(YAP_IsNumberTerm,(YAP_Term)); + /* YAP_Bool IsDbRefTerm(YAP_Term) */ extern X_API YAP_Bool PROTO(YAP_IsDbRefTerm,(YAP_Term)); @@ -121,6 +124,9 @@ extern X_API YAP_Bool PROTO(YAP_IsPairTerm,(YAP_Term)); /* YAP_Bool IsApplTerm(YAP_Term) */ extern X_API YAP_Bool PROTO(YAP_IsApplTerm,(YAP_Term)); +/* YAP_Bool IsCompoundTerm(YAP_Term) */ +extern X_API YAP_Bool PROTO(YAP_IsCompoundTerm,(YAP_Term)); + /* Term MkIntTerm(YAP_Int) */ extern X_API YAP_Term PROTO(YAP_MkIntTerm,(YAP_Int)); @@ -237,6 +243,9 @@ extern X_API void PROTO(YAP_UserCPredicateWithArgs,(CONST char *, YAP_Bool (*)(v arity, int extra) */ extern X_API void PROTO(YAP_UserBackCPredicate,(CONST char *, YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Arity, unsigned int)); +/* YAP_Int YAP_ListLength(YAP_Term t) */ +extern X_API YAP_Int PROTO(YAP_ListLength,(YAP_Term)); + /* void UserBackCPredicate(char *name, int *init(), int *cont(), int *cut(), int arity, int extra) */ extern X_API void PROTO(YAP_UserBackCutCPredicate,(CONST char *, YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Arity, unsigned int)); @@ -310,7 +319,7 @@ extern X_API void PROTO(YAP_Error,(int, YAP_Term, CONST char *, ...)); extern X_API YAP_Term PROTO(YAP_Read,(void *)); /* void YAP_Write(YAP_Term,void (*)(int),int) */ -extern X_API void PROTO(YAP_Write,(YAP_Term,void (*)(int),int)); +extern X_API void PROTO(YAP_Write,(YAP_Term,void *,int)); /* void YAP_WriteBufffer(YAP_Term,char *,unsgined int,int) */ extern X_API void PROTO(YAP_WriteBuffer,(YAP_Term,char *,unsigned int,int)); @@ -534,6 +543,9 @@ extern X_API int PROTO(YAP_Erase,(void *)); /* term utilities */ extern X_API int PROTO(YAP_Variant,(YAP_Term,YAP_Term)); +extern X_API YAP_Int PROTO(YAP_NumberVars,(YAP_Term,YAP_Int)); +extern X_API YAP_Term PROTO(YAP_UnNumberVars,(YAP_Term)); +extern X_API int PROTO(YAP_IsNumberedVariable,(YAP_Term)); extern X_API int PROTO(YAP_Unifiable,(YAP_Term,YAP_Term)); extern X_API int PROTO(YAP_ExactlyEqual,(YAP_Term,YAP_Term)); extern X_API YAP_Int PROTO(YAP_TermHash,(YAP_Term, YAP_Int, YAP_Int, int)); From 01411135832f2b3b78ac09a0a9742934e2652422 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:53:21 +0900 Subject: [PATCH 30/40] fix bug. --- packages/udi/rtree_udi.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/udi/rtree_udi.c b/packages/udi/rtree_udi.c index 2095164a1..141d64ee7 100644 --- a/packages/udi/rtree_udi.c +++ b/packages/udi/rtree_udi.c @@ -12,7 +12,7 @@ #include "rtree_udi_i.h" #include "rtree_udi.h" -static int YAP_IsNumberTerm (Term term, YAP_Float *n) +static int YAP_IsNumberTermToFloat (Term term, YAP_Float *n) { if (YAP_IsIntTerm (term) != FALSE) { @@ -41,7 +41,7 @@ static rect_t RectOfTerm (Term term) for (i = 0; YAP_IsPairTerm(term) && i < 4; i++) { tmp = YAP_HeadOfTerm (term); - if (!YAP_IsNumberTerm(tmp,&(rect.coords[i]))) + if (!YAP_IsNumberTermToFloat(tmp,&(rect.coords[i]))) return (RectInit()); term = YAP_TailOfTerm (term); } From b85f9d1d54fe7435b906c11001ec673176eb86d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:53:49 +0900 Subject: [PATCH 31/40] use new interface code. --- H/Yap.h | 517 ++------------------------------------------------------ 1 file changed, 13 insertions(+), 504 deletions(-) diff --git a/H/Yap.h b/H/Yap.h index 402948b8b..ae0b0c82b 100644 --- a/H/Yap.h +++ b/H/Yap.h @@ -7,7 +7,7 @@ * * ************************************************************************** * * -* File: Yap.h.m4 * +* File: Yap.h * * mods: * * comments: main header file for YAP * * version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ * @@ -120,6 +120,15 @@ #define DUMMY_FILLER_FOR_ABS_TYPE int dummy; #endif /* HAVE_GCC */ +#ifdef THREADS +#if USE_PTHREAD_LOCKING +#ifndef _XOPEN_SOURCE +#define _XOPEN_SOURCE 600 +#endif /* !_XOPEN_SOURCE */ +#endif /* USE_PTHREAD_LOCKING */ +#include +#endif /* THREADS */ + #ifndef ADTDEFS_C #define EXTERN static #else @@ -134,109 +143,9 @@ /* null pointer */ #define NIL 0 - /* Basic types */ -/* defines integer types Int and UInt (unsigned) with the same size as a ptr -** and integer types Short and UShort with half the size of a ptr */ - -#ifdef THREADS -#if USE_PTHREAD_LOCKING -#ifndef _XOPEN_SOURCE -#define _XOPEN_SOURCE 600 -#endif /* !_XOPEN_SOURCE */ -#endif /* USE_PTHREAD_LOCKING */ -#include -#endif /* THREADS */ - -#if SIZEOF_INT_P==4 - -#if SIZEOF_INT==4 -/* */ typedef int Int; -/* */ typedef unsigned int UInt; - -#define Int_FORMAT "%d" -#define UInt_FORMAT "%u" - -#elif SIZEOF_LONG_INT==4 -/* */ typedef long int Int; -/* */ typedef unsigned long int UInt; - -#define Int_FORMAT "%ld" -#define UInt_FORMAT "%lu" - -#else -#error Yap require integer types of the same size as a pointer -#endif - -#if SIZEOF_SHORT_INT==2 -/* */ typedef short int Short; -/* */ typedef unsigned short int UShort; - -#else -# error Yap requires integer types half the size of a pointer -#endif - -#elif SIZEOF_INT_P==8 - -#if SIZEOF_INT==8 -/* */ typedef int Int; -/* */ typedef unsigned int UInt; - -#define Int_FORMAT "%d" -#define UInt_FORMAT "%u" - -#elif SIZEOF_LONG_INT==8 -/* */ typedef long int Int; -/* */ typedef unsigned long int UInt; - -#define Int_FORMAT "%ld" -#define UInt_FORMAT "%lu" - -# elif SIZEOF_LONG_LONG_INT==8 -/* */ typedef long long int Int; -/* */ typedef unsigned long long int UInt; - -#define Int_FORMAT "%I64d" -#define UInt_FORMAT "%I64u" - -# else -# error Yap requires integer types of the same size as a pointer -# endif - -# if SIZEOF_SHORT_INT==4 -/* */ typedef short int Short; -/* */ typedef unsigned short int UShort; - -# elif SIZEOF_INT==4 -/* */ typedef int Short; -/* */ typedef unsigned int UShort; - -# else -# error Yap requires integer types half the size of a pointer -# endif - -#else - -# error Yap requires pointers of size 4 or 8 - -#endif - -/* */ typedef double Float; - -#if SIZEOF_INT @@ -631,123 +509,7 @@ typedef enum #include "Yapproto.h" -/***********************************************************************/ - - /* - absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var - - with AbsAppl(t) : *CELL -> Term - and RepAppl(t) : Term -> *CELL - - and AbsPair(t) : *CELL -> Term - and RepPair(t) : Term -> *CELL - - and IsIntTerm(t) = ... - and IsAtomTerm(t) = ... - and IsVarTerm(t) = ... - and IsPairTerm(t) = ... - and IsApplTerm(t) = ... - and IsFloatTerm(t) = ... - and IsRefTerm(t) = ... - and IsNonVarTerm(t) = ! IsVar(t) - and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t) - and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t) - and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t) - - and MkIntTerm(n) = ... - and MkFloatTerm(f) = ... - and MkAtomTerm(a) = ... - and MkVarTerm(r) = ... - and MkApplTerm(f,n,args) = ... - and MkPairTerm(hd,tl) = ... - and MkRefTerm(R) = ... - - and PtrOfTerm(t) : Term -> CELL * = ... - and IntOfTerm(t) : Term -> int = ... - and FloatOfTerm(t) : Term -> flt = ... - and AtomOfTerm(t) : Term -> Atom = ... - and VarOfTerm(t) : Term -> *Term = .... - and HeadOfTerm(t) : Term -> Term = ... - and TailOfTerm(t) : Term -> Term = ... - and FunctorOfTerm(t) : Term -> Functor = ... - and ArgOfTerm(i,t) : Term -> Term= ... - and RefOfTerm(t) : Term -> DBRef = ... - - */ - -/* - YAP can use several different tag schemes, according to the kind of - machine we are experimenting with. -*/ - -#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME) - -#include "Tags_32bits.h" - -#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */ - -/* AIX will by default place mmaped segments at 0x30000000. This is - incompatible with the high tag scheme. Linux-ELF also does not like - if you place things in the lower addresses (power to the libc people). -*/ - -#if defined(__APPLE__) -/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */ -#undef USE_DL_MALLOC -#ifndef USE_SYSTEM_MALLOC -#define USE_SYSTEM_MALLOC 1 -#endif -#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__) -#define USE_LOW32_TAGS 1 -#endif - -#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) - -#include "Tags_32Ops.h" - -#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */ - -#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS) - -#include "Tags_32LowTag.h" - -#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */ - -#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) - -#include "Tags_64bits.h" - -#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */ - -#if !LONG_ADDRESSES - -#include "Tags_24bits.h" - -#endif /* !LONG_ADDRESSES */ - -#ifdef TAG_LOW_BITS_32 - -#if !GC_NO_TAGS -#define MBIT 0x80000000 -#define RBIT 0x40000000 - -#if IN_SECOND_QUADRANT -#define INVERT_RBIT 1 /* RBIT is 1 by default */ -#endif -#endif /* !GC_NO_TAGS */ - -#else - -#if !GC_NO_TAGS -#if defined(YAPOR_SBA) && defined(__linux__) -#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */ -#else -#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */ -#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */ -#endif -#endif /* !GC_NO_TAGS */ - -#endif +#include "YapTags.h" #define TermSize sizeof(Term) @@ -771,259 +533,6 @@ extern ADDR Yap_HeapBase; extern int Yap_output_msg; #endif -/************************************************************************************************* - ??? -*************************************************************************************************/ - -#define MkVarTerm() MkVarTerm__( PASS_REGS1 ) -#define MkPairTerm(A,B) MkPairTerm__( A, B PASS_REGS ) - -/************************************************************************************************* - applies to unbound variables -*************************************************************************************************/ - -inline EXTERN Term *VarOfTerm (Term t); - -inline EXTERN Term * -VarOfTerm (Term t) -{ - return (Term *) (t); -} - - -#ifdef YAPOR_SBA - -inline EXTERN Term MkVarTerm__ ( USES_REGS1 ); - -inline EXTERN Term -MkVarTerm__ ( USES_REGS1 ) -{ - return (Term) ((*H = 0, H++)); -} - - - -inline EXTERN int IsUnboundVar (Term *); - -inline EXTERN int -IsUnboundVar (Term * t) -{ - return (int) (*(t) == 0); -} - - -#else - -inline EXTERN Term MkVarTerm__ ( USES_REGS1 ); - -inline EXTERN Term -MkVarTerm__ ( USES_REGS1 ) -{ - return (Term) ((*H = (CELL) H, H++)); -} - - - -inline EXTERN int IsUnboundVar (Term *); - -inline EXTERN int -IsUnboundVar (Term * t) -{ - return (int) (*(t) == (Term) (t)); -} - - -#endif - -inline EXTERN CELL *PtrOfTerm (Term); - -inline EXTERN CELL * -PtrOfTerm (Term t) -{ - return (CELL *) (*(CELL *) (t)); -} - - - - -inline EXTERN Functor FunctorOfTerm (Term); - -inline EXTERN Functor -FunctorOfTerm (Term t) -{ - return (Functor) (*RepAppl (t)); -} - - -#if USE_LOW32_TAGS - -inline EXTERN Term MkAtomTerm (Atom); - -inline EXTERN Term -MkAtomTerm (Atom a) -{ - return (Term) (AtomTag | (CELL) (a)); -} - - - -inline EXTERN Atom AtomOfTerm (Term t); - -inline EXTERN Atom -AtomOfTerm (Term t) -{ - return (Atom) ((~AtomTag & (CELL) (t))); -} - - -#else - -inline EXTERN Term MkAtomTerm (Atom); - -inline EXTERN Term -MkAtomTerm (Atom a) -{ - return (Term) (TAGGEDA ((CELL)AtomTag, (CELL) (a))); -} - - - -inline EXTERN Atom AtomOfTerm (Term t); - -inline EXTERN Atom -AtomOfTerm (Term t) -{ - return (Atom) (NonTagPart (t)); -} - - -#endif - -inline EXTERN int IsAtomTerm (Term); - -inline EXTERN int -IsAtomTerm (Term t) -{ - return (int) (CHKTAG ((t), AtomTag)); -} - - - - -inline EXTERN Term MkIntTerm (Int); - -inline EXTERN Term -MkIntTerm (Int n) -{ - return (Term) (TAGGED (NumberTag, (n))); -} - - -/* - A constant to subtract or add to a well-known term, we assume no - overflow problems are possible -*/ - -inline EXTERN Term MkIntConstant (Int); - -inline EXTERN Term -MkIntConstant (Int n) -{ - return (Term) (NONTAGGED (NumberTag, (n))); -} - - - -inline EXTERN int IsIntTerm (Term); - -inline EXTERN int -IsIntTerm (Term t) -{ - return (int) (CHKTAG ((t), NumberTag)); -} - - - -EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) ); - -EXTERN inline Term -MkPairTerm__ (Term head, Term tail USES_REGS) -{ - register CELL *p = H; - - H[0] = head; - H[1] = tail; - H += 2; - return (AbsPair (p)); -} - - -/* Needed to handle numbers: - these two macros are fundamental in the integer/float conversions */ - -#ifdef M_WILLIAMS -#define IntInBnd(X) (TRUE) -#else -#ifdef TAGS_FAST_OPS -#define IntInBnd(X) (Unsigned( ( (Int)(X) >> (32-7) ) + 1) <= 1) -#else -#define IntInBnd(X) ( (X) < MAX_ABS_INT && \ - (X) > -MAX_ABS_INT-1L ) -#endif -#endif -#ifdef C_PROLOG -#define FlIsInt(X) ( (X) == (Int)(X) && IntInBnd((X)) ) -#else -#define FlIsInt(X) ( FALSE ) -#endif - - -/* - There are two types of functors: - - o Special functors mark special terms - on the heap that should be seen as constants. - - o Standard functors mark normal applications. - -*/ - -#include "TermExt.h" - -#define IsAccessFunc(func) ((func) == FunctorAccess) - - -inline EXTERN Term MkIntegerTerm (Int); - -inline EXTERN Term -MkIntegerTerm (Int n) -{ - return (Term) (IntInBnd (n) ? MkIntTerm (n) : MkLongIntTerm (n)); -} - - - -inline EXTERN int IsIntegerTerm (Term); - -inline EXTERN int -IsIntegerTerm (Term t) -{ - return (int) (IsIntTerm (t) || IsLongIntTerm (t)); -} - - - -inline EXTERN Int IntegerOfTerm (Term); - -inline EXTERN Int -IntegerOfTerm (Term t) -{ - - return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t)); -} - - - /************************************************************************************************* variables concerned with atoms table *************************************************************************************************/ From 5ce8d637efe7f13a147fa72dd576734f11c74741 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:54:18 +0900 Subject: [PATCH 32/40] fix AtomLength clash --- H/pl-yap.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/H/pl-yap.h b/H/pl-yap.h index f49693148..b474639f2 100644 --- a/H/pl-yap.h +++ b/H/pl-yap.h @@ -124,6 +124,9 @@ void PL_license(const char *license, const char *module); #define isVar(A) YAP_IsVarTerm((A)) #define valReal(w) YAP_FloatOfTerm((w)) #define valFloat(w) YAP_FloatOfTerm((w)) +#ifdef AtomLength /* there is another AtomLength in the system */ +#undef AtomLength +#endif #define AtomLength(w) YAP_AtomNameLength(w) #define atomValue(atom) YAP_AtomFromSWIAtom(atom) #define atomFromTerm(term) YAP_SWIAtomFromAtom(YAP_AtomOfTerm(term)) From 1d2de81e86e03ee96857f6757380044adce048ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:54:51 +0900 Subject: [PATCH 33/40] update bprolog emulation stuff. --- library/dialect/bprolog.yap | 222 +++++++++++++++++++++++++ library/dialect/bprolog/actionrules.pl | 26 ++- library/dialect/bprolog/arrays.yap | 2 +- library/dialect/bprolog/fli/bprolog.h | 59 +++++-- library/dialect/bprolog/hashtable.yap | 15 +- 5 files changed, 302 insertions(+), 22 deletions(-) diff --git a/library/dialect/bprolog.yap b/library/dialect/bprolog.yap index cec080621..c2cdcc067 100644 --- a/library/dialect/bprolog.yap +++ b/library/dialect/bprolog.yap @@ -1,7 +1,229 @@ +:- set_prolog_flag(dollar_as_lower_case,on). + +:- use_module(library(lists)). +:- use_module(library(hacks),[ + current_choicepoint/1, + cut_by/1]). +:- use_module(library(terms)). +:- use_module(library(system)). + :- ensure_loaded(bprolog/arrays). :- ensure_loaded(bprolog/hashtable). %:- ensure_loaded(bprolog/actionrules). :- ensure_loaded(bprolog/foreach). %:- ensure_loaded(bprolog/compile_foreach). + +:- op(700, xfx, [?=]). +:- op(200, fx, (@)). + +X ?= Y :- unifiable(X,Y,_). + +global_set(F,N,Value) :- + atomic_concat([F,'/',N],Key), + nb_setval(Key, Value). + +global_set(F,Value) :- + atom_concat([F,'/0'],Key), + nb_setval(Key, Value). + +global_get(F,Arity,Value) :- + atomic_concat([F,'/',Arity],Key), + nb_getval(Key, Value). + +global_get(F,Value) :- + atom_concat([F,'/0'],Key), + nb_getval(Key, Value). + +global_del(F,Arity) :- + atomic_concat([F,'/',Arity],Key), + catch(nb_delete(Key),_,true). + +global_del(F) :- + atom_concat([F,'/0'],Key), + catch(nb_delete(Key),_,true). + +getclauses1(File, Prog, _Opts) :- + findall(Clause, '$bpe_get_clause_from_file'(File, Clause), Prog0), + '$bpe_get_preds'(Prog0, Prog). + +'$bpe_open_file'(File, Dir, S) :- + absolute_file_name(File, Abs, [expand(true),access(read)]), + file_directory_name(Abs, Dir), + open(Abs, read, S). + +'$bpe_get_clause_from_file'(File, Clause) :- + '$bpe_open_file'(File, Dir, S), + working_directory(Old, Dir), + repeat, + read(S, Clause0), + ( Clause0 = end_of_file -> + !, + working_directory(Dir, Old), + fail + ; + %ugh, but we have to process include directives on the spot... + Clause0 = (:- include(Include)) + -> + '$bpe_get_clause_from_file'(Include, Clause) + ; + Clause = Clause0 + ). + +'$bpe_get_preds'(Decl.Prog0, pred(F,N,Modes,Delay,Tabled,Cls).NProg) :- + '$get_pred'(Decl, F, N, Modes,Delay, Tabled, Cls, Cls0), !, + '$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, Cls0, ProgF, []), + '$bpe_get_preds'(ProgF, NProg). +'$bpe_get_preds'(_Decl.Prog0, NProg) :- + '$bpe_get_preds'(Prog0, NProg). +'$bpe_get_preds'([], []). + +'$bpe_process_pred'([], _F, N, Mode, _Delay, _Tabled, []) --> + { '$init_mode'(N, Mode) }. +'$bpe_process_pred'(Call.Prog0, F,N,Modes,Delay,Tabled, Cls0) --> + { '$get_pred'(Call, F, N, Modes, Delay, Tabled, Cls0, ClsI) }, !, + '$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, ClsI). +'$bpe_process_pred'(Call.Prog0, F,N,Modes,Delay,Tabled, Cls0) --> + [ Call ], + '$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, Cls0). + +'$init_mode'(_N, Mode) :- nonvar(Mode), !. +'$init_mode'(0, []) :- !. +'$init_mode'(I, [d|Mode]) :- !, + I0 is I-1, + '$init_mode'(I0, Mode). + +'$get_pred'((P :- Q), F, N, _Modes, _Delay, _Tabled) --> + { functor(P, F, N), ! }, + [(P:-Q)]. +'$get_pred'((:- mode Q), F, N, _Modes, _Delay, _Tabled) --> + { functor(Q, F, N), !, Q =.. [_|Modes0], + '$bpe_cvt_modes'(Modes0,Modes,[]) + }, + []. +%'$get_pred'((:- table _), F, N, Modes, Delay, Tabled) --> +% { functor(Q, F, N), !, Q =.. [_|Modes] }, +% []. +'$get_pred'((:- _), _F, _N, _Modes, _Delay, _Tabled) --> !, { fail }. +'$get_pred'((P), F, N, _Modes, _Delay, _Tabled) --> + { functor(P, F, N), ! }, + [(P)]. + + +'$bpe_cvt_modes'(Mode.Modes0) --> [NewMode], + { '$bpe_cvt_mode'(Mode, NewMode) }, + '$bpe_cvt_modes'(Modes0). +'$bpe_cvt_modes'([]) --> []. + +'$bpe_cvt_mode'(Mode, Mode). + +list_to_and([], true). +list_to_and([G], G). +list_to_and([G1,G2|Gs], (G1, NGs)) :- + list_to_and([G2|Gs], NGs). + +preprocess_cl(Cl, Cl, _, _, _, _). + +phase_1_process(Prog, Prog). + +compileProgToFile(_,_File,[]). +compileProgToFile(_,File,pred(F,N,_,_,Tabled,Clauses).Prog2) :- + (nonvar(Tabled) -> table(F/N) ; true), + functor(S,F,N), + assert(b_IS_CONSULTED_c(S)), + '$assert_clauses'(Clauses), + compileProgToFile(_,File,Prog2). + +'$assert_clauses'([]). +'$assert_clauses'(Cl.Clauses) :- + assert_static(Cl), + '$assert_clauses'(Clauses). + +'$myload'(_F). + +initialize_table :- abolish_all_tables. + +:- dynamic b_IS_DEBUG_MODE/0. + +'_$savecp'(B) :- current_choicepoint(B). +'_$cutto'(B) :- cut_by(B). + +X <= Y :- subsumes_chk(Y,X). + +cputime(X) :- statistics(cputime,[X,_]). + +vars_set(Term, Vars) :- + term_variables(Term, Vars). + +sort(=<, L, R) :- + length(L, N), + $bp_sort(@=<, N, L, _, R1), !, + R = R1. +sort(>=, L, R) :- + length(L, N), + $bp_sort(@>=, N, L, _, R1), !, + R = R1. +sort(<, L, R) :- + length(L, N), + $bp_sort2(@<, N, L, _, R1), !, + R = R1. +sort(>, L, R) :- + length(L, N), + $bp_sort2(@>, N, L, _, R1), !, + R = R1. + +$bp_sort(P, 2, [X1, X2|L], L, R) :- !, + ( + call(P, X1, X2) -> + R = [X1,X2] + ; + R = [X2,X1] + ). +$bp_sort(_, 1, [X|L], L, [X]) :- !. +$bp_sort(_, 0, L, L, []) :- !. +$bp_sort(P, N, L1, L3, R) :- + N1 is N // 2, + plus(N1, N2, N), + $bp_sort(P, N1, L1, L2, R1), + $bp_sort(P, N2, L2, L3, R2), + $bp_predmerge(P, R1, R2, R). + +$bp_predmerge(_, [], R, R) :- !. +$bp_predmerge(_, R, [], R) :- !. +$bp_predmerge(P, [H1|T1], [H2|T2], [H1|Result]) :- + call(P, H1, H2), !, + $bp_predmerge(P, T1, [H2|T2], Result). +$bp_predmerge(P, [H1|T1], [H2|T2], [H2|Result]) :- + $bp_predmerge(P, [H1|T1], T2, Result). + +$bp_sort2(P, 2, [X1, X2|L], L, R) :- !, + ( + call(P, X1, X2) -> + R = [X1,X2] + ; + X1 == X2 + -> + R = [X1] + ; + R = [X2,X1] + ). +$bp_sort2(_, 1, [X|L], L, [X]) :- !. +$bp_sort2(_, 0, L, L, []) :- !. +$bp_sort2(P, N, L1, L3, R) :- + N1 is N // 2, + plus(N1, N2, N), + $bp_sort(P, N1, L1, L2, R1), + $bp_sort(P, N2, L2, L3, R2), + $bp_predmerge(P, R1, R2, R). + +$bp_predmerge2(_, [], R, R) :- !. +$bp_predmerge2(_, R, [], R) :- !. +$bp_predmerge2(P, [H1|T1], [H2|T2], [H1|Result]) :- + call(P, H1, H2), !, + $bp_predmerge(P, T1, [H2|T2], Result). +$bp_predmerge2(P, [H1|T1], [H2|T2], [H1|Result]) :- + H1 == H2, !, + $bp_predmerge(P, T1, T2, Result). +$bp_predmerge2(P, [H1|T1], [H2|T2], [H2|Result]) :- + $bp_predmerge(P, [H1|T1], T2, Result). diff --git a/library/dialect/bprolog/actionrules.pl b/library/dialect/bprolog/actionrules.pl index cf8c95c13..a8589cb59 100644 --- a/library/dialect/bprolog/actionrules.pl +++ b/library/dialect/bprolog/actionrules.pl @@ -33,6 +33,7 @@ :- module(actionrules,[op(1200,xfx,=>), op(1200,xfx,?=>), op(1000,xfy,:::), + op(900,xfy,<=), post/1, post_event/2, post_event_df/2, @@ -42,6 +43,8 @@ :- use_module(library(lists)). +:- dynamic ar_term/2, extra_ar_term/2. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % the built-ins and the preds needed in the transformation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -332,7 +335,8 @@ ar_translate([AR|ARs],Module,Program,Errors) :- get_head(AR,ARHead), collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs), ars2p([AR|ActionPredRest],det,ARHead,Program,Errors,TailProgram,TailErrors), - ar_translate(RestARs,Module,TailProgram,TailErrors). + extra_ars(AR, TailProgram, NTailProgram), + ar_translate(RestARs,Module,NTailProgram,TailErrors). nondet_ar_translate([],_,Program,Program,[]). nondet_ar_translate([AR|ARs],Module,Program,EndProgram,Errors) :- @@ -375,6 +379,20 @@ ar_expand(Term, []) :- prolog_load_context(file,File), get_arinfo(Term,ARInfo,_), assert(nondet_ar_term(File,ARInfo)). +ar_expand(Term, []) :- + Term = (Head :- Body ), + prolog_load_context(file,File), + functor(Head, Na, Ar), + functor(Empty, Na, Ar), + ar_term(File,ar(Empty,_,_,_)), !, + assert(extra_ar_term(File,ar(Head, Body))). +ar_expand(Head, []) :- + prolog_load_context(file,File), + functor(Head, Na, Ar), + functor(Empty, Na, Ar), + ar_term(File,ar(Empty,_,_,_)), !, + assert(extra_ar_term(File,ar(Head, true))). + ar_expand(end_of_file, FinalProgram) :- prolog_load_context(file,File), compile_ar(File, DetProgram), @@ -405,6 +423,12 @@ compile_nondet_ar(File, FinalProgram, StartProgram) :- report_errors(Errors) :- throw(action_rule_error(Errors)). % for now +extra_ars(ar(Head,_,_,_), LF, L0) :- + functor(Head, N, A), + functor(Empty, N, A), + findall((Empty :- B), extra_ar_term(_,ar(Empty, B)), LF, L0). + + /******************************* * MUST BE LAST! * *******************************/ diff --git a/library/dialect/bprolog/arrays.yap b/library/dialect/bprolog/arrays.yap index 43a319ff4..88dd2ee33 100644 --- a/library/dialect/bprolog/arrays.yap +++ b/library/dialect/bprolog/arrays.yap @@ -1,5 +1,5 @@ -:- module(bparrays, [new_array/2, a2_new/3, a3_new/4. is_array/1, '$aget'/3]). +:- module(bparrays, [new_array/2, a2_new/3, a3_new/4, is_array/1, '$aget'/3]). :- use_module(library(lists), [flatten/2]). diff --git a/library/dialect/bprolog/fli/bprolog.h b/library/dialect/bprolog/fli/bprolog.h index 4ee3b7676..f25d6e8db 100644 --- a/library/dialect/bprolog/fli/bprolog.h +++ b/library/dialect/bprolog/fli/bprolog.h @@ -1,5 +1,10 @@ +#ifndef BPROLOG_H + +#define BPROLOG_H 1 + #include +#include typedef YAP_Term TERM; typedef YAP_Int BPLONG; @@ -31,10 +36,10 @@ typedef BPLONG *BPLONG_PTR; #define bp_is_structure(t) YAP_IsApplTerm(t) //extern int bp_is_compound(TERM t) -#define bp_is_compound(t) ( YAP_IsApplTerm(t) || YAP_IsPairTerm(t) ) +#define bp_is_compound(t) YAP_IsCompoundTerm(t) //extern int bp_is_unifiable(TERM t1, Term t2) -#define bp_is_unifiable(t1, t2) YAP_unifiable_NOT_IMPLEMENTED(t1, t2) +#define bp_is_unifiable(t1, t2) YAP_unifiable(t1, t2) //extern int bp_is_identical(TERM t1, Term t2) #define bp_is_identical(t1, t2) YAP_ExactlyEqual(t1, t2) @@ -81,10 +86,10 @@ bp_get_arity(TERM t) #define bp_get_arg(i, t) YAP_ArgOfTerm(i, t) //TERM bp_get_car(Term t) -#define bp_get_car(t) YAP_HeadOfTerm(i, t) +#define bp_get_car(t) YAP_HeadOfTerm(t) //TERM bp_get_cdr(Term t) -#define bp_get_cdr(t) YAP_TailOfTerm(i, t) +#define bp_get_cdr(t) YAP_TailOfTerm(t) // void bp_write(TERM t) #define bp_write(t) YAP_WriteTerm(t, NULL, 0) @@ -99,7 +104,7 @@ bp_get_arity(TERM t) #define bp_build_float(f) YAP_MkFloatTerm(f) // TERM bp_build_atom(char *name) -#define bp_build_atom(name) YAP_MkAtomTerm(YAP_LookupAtom(name)) +#define bp_build_atom(name) YAP_MkAtomTerm(YAP_LookupAtom((name))) // TERM bp_build_nil() #define bp_build_nil() YAP_TermNil() @@ -114,29 +119,51 @@ bp_get_arity(TERM t) #define bp_insert_pred(name, arity, func) YAP_UserCPredicate(name, func, arity) // int bp_call_string(char *goal) -#define bp_call_string(goal) YAP_RunGoal(YAP_ReadBuffer(goal, NULL)) +extern inline int +bp_call_string(const char *goal) { + return YAP_RunGoal(YAP_ReadBuffer(goal, NULL)); +} // int bp_call_term(TERM goal) -#define bp_call_term(goal) YAP_RunGoal(goal) +extern inline int +bp_call_term(TERM t) { + return YAP_RunGoal(t); +} -// void bp_mount_query_string(char *goal) -#define bp_mount_query_string(goal) bp_t = YAP_ReadBuffer(goal, NULL); +#define TOAM_NOTSET 0L -// void bp_mount_query_term(TERM goal) -// #define bp_mount_query_term(goal) bp_t = t; +#define curr_out stdout -TERM bp_t; +#define BP_ERROR (-1) + +#define INTERRUPT 0x2L + +#define exception YAP_BPROLOG_exception +#define curr_toam_status YAP_BPROLOG_curr_toam_status + +extern YAP_Term YAP_BPROLOG_curr_toam_status; +extern YAP_Int YAP_BPROLOG_exception; // TERM bp_next_solution() -static int bp_next_solution(void) +extern inline int bp_next_solution(void) { - if (bp_t) { - TERM goal = bp_t; - bp_t = 0L; + if (curr_toam_status) { + TERM goal = curr_toam_status; + curr_toam_status = TOAM_NOTSET; return YAP_RunGoal(goal); } return YAP_RestartGoal(); } +// void bp_mount_query_string(char *goal) +#define bp_mount_query_string(goal) (curr_toam_status = YAP_ReadBuffer(goal, NULL)) +// void bp_mount_query_term(TERM goal) +extern inline int +bp_mount_query_term(TERM goal) +{ + curr_toam_status = goal; + return TRUE; +} +#endif /* BPROLOG_H */ diff --git a/library/dialect/bprolog/hashtable.yap b/library/dialect/bprolog/hashtable.yap index 983b5a69b..8cacf7cca 100644 --- a/library/dialect/bprolog/hashtable.yap +++ b/library/dialect/bprolog/hashtable.yap @@ -1,3 +1,5 @@ +%% -*- Prolog -*- + :- module(bphash, [new_hashtable/1, new_hashtable/2, is_hashtable/1, @@ -12,7 +14,7 @@ :- use_module(library(bhash), [b_hash_new/2, is_b_hash/1, b_hash_lookup/3, - b_hash_insert/3, + b_hash_insert/4, b_hash_size/2, b_hash_to_list/2, b_hash_values_to_list/2, @@ -31,19 +33,20 @@ hashtable_get(Hash, Key, Value) :- b_hash_lookup(Key, Value, Hash). hashtable_put(Hash, Key, Value) :- - b_hash_insert(Key, Value, Hash). + b_hash_insert(Hash, Key, Value, Hash). hashtable_register(Hash, Key, Value) :- b_hash_lookup(Key, Value0, Hash), !, Value0 = Value. hashtable_register(Hash, Key, Value) :- - b_hash_insert(Hash, Key, Value). + b_hash_insert(Hash, Key, Value, Hash). hashtable_size(Hash, Size) :- b_hash_size(Hash, Size). hashtable_to_list(Hash, List) :- - b_hash_to_list(Hash, List). + b_hash_to_list(Hash, List0), + keylist_to_bp(List0, List). hashtable_keys_to_list(Hash, List) :- b_hash_keys_to_list(Hash, List). @@ -51,6 +54,10 @@ hashtable_keys_to_list(Hash, List) :- hashtable_values_to_list(Hash, List) :- b_hash_values_to_list(Hash, List). +keylist_to_bp([], []). +keylist_to_bp((X-Y).List0, (X=Y).List) :- + keylist_to_bp(List0, List). + From 9397c9336d45756d92f379039b480c2875394658 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:55:42 +0900 Subject: [PATCH 34/40] make this callable from foeign code. --- H/TermExt.h | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/H/TermExt.h b/H/TermExt.h index 625094c59..779f37f74 100644 --- a/H/TermExt.h +++ b/H/TermExt.h @@ -58,13 +58,19 @@ blob_type; #define FunctorDouble ((Functor)(double_e)) #define EndSpecials (double_e+sizeof(Functor *)) + inline EXTERN int IsAttVar (CELL *pt); inline EXTERN int IsAttVar (CELL *pt) { +#ifdef _YAP_NOT_INSTALLED_ CACHE_REGS - return (pt)[-1] == (CELL)attvar_e && pt < H; + return (pt)[-1] == (CELL)attvar_e + && pt < H; +#else + return (pt)[-1] == (CELL)attvar_e; +#endif } inline EXTERN int GlobalIsAttVar (CELL *pt); @@ -142,6 +148,8 @@ exts; #endif +#ifdef _YAP_NOT_INSTALLED_ + /* make sure that these data structures are the first thing to be allocated in the heap when we start the system */ #ifdef THREADS @@ -171,6 +179,7 @@ inline EXTERN Float STD_PROTO (CpFloatUnaligned, (CELL *)); #if SIZEOF_DOUBLE == SIZEOF_LONG_INT + inline EXTERN Term MkFloatTerm (Float); inline EXTERN Term @@ -246,7 +255,6 @@ MkFloatTerm (Float dbl) } - inline EXTERN Float FloatOfTerm (Term t); inline EXTERN Float @@ -264,6 +272,14 @@ FloatOfTerm (Term t) #endif #endif +Term STD_PROTO (Yap_MkBlobStringTerm, (const char *, size_t len)); +Term STD_PROTO (Yap_MkBlobWideStringTerm, (const wchar_t *, size_t len)); +char *STD_PROTO (Yap_BlobStringOfTerm, (Term)); +wchar_t *STD_PROTO (Yap_BlobWideStringOfTerm, (Term)); +char *STD_PROTO (Yap_BlobStringOfTermAndLength, (Term, size_t *)); + +#endif /* YAP_NOT_INSTALLED */ + inline EXTERN int IsFloatTerm (Term); @@ -278,6 +294,7 @@ IsFloatTerm (Term t) /* extern Functor FunctorLongInt; */ +#ifdef _YAP_NOT_INSTALLED_ inline EXTERN Term MkLongIntTerm (Int); inline EXTERN Term @@ -291,6 +308,8 @@ MkLongIntTerm (Int i) return AbsAppl(H - 3); } +#endif + inline EXTERN Int LongIntOfTerm (Term t); inline EXTERN Int @@ -402,12 +421,6 @@ typedef struct string_struct { UInt len; } blob_string_t; -Term STD_PROTO (Yap_MkBlobStringTerm, (const char *, size_t len)); -Term STD_PROTO (Yap_MkBlobWideStringTerm, (const wchar_t *, size_t len)); -char *STD_PROTO (Yap_BlobStringOfTerm, (Term)); -wchar_t *STD_PROTO (Yap_BlobWideStringOfTerm, (Term)); -char *STD_PROTO (Yap_BlobStringOfTermAndLength, (Term, size_t *)); - inline EXTERN int IsBlobStringTerm (Term); inline EXTERN int @@ -591,6 +604,8 @@ IsAttachedTerm (Term t) #endif +#ifdef _YAP_NOT_INSTALLED_ + inline EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL)); EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL)); @@ -664,3 +679,4 @@ CELL Yap_Double_key(Term t) return Yap_DoubleP_key(RepAppl(t)+1); } +#endif From 2ee9981a116e91f918917a39ac711f03215a1792 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:55:56 +0900 Subject: [PATCH 35/40] new Makefiles and prototypes. --- H/Yapproto.h | 4 +- Makefile.in | 27 ++++++---- config.h.in | 9 +--- configure | 3 ++ configure.in | 1 + docs/yap.tex | 24 +++++++++ include/YapTags.h | 119 -------------------------------------------- library/Makefile.in | 2 + 8 files changed, 50 insertions(+), 139 deletions(-) delete mode 100644 include/YapTags.h diff --git a/H/Yapproto.h b/H/Yapproto.h index 6fa38dff5..54e63a568 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -379,7 +379,7 @@ int STD_PROTO(Yap_rational_tree_loop, (CELL *, CELL *, CELL **, CELL ** void STD_PROTO(Yap_InitAbsmi,(void)); void STD_PROTO(Yap_InitUnify,(void)); void STD_PROTO(Yap_TrimTrail,(void)); -void STD_PROTO(Yap_Unifiable,(Term d0, Term d1)); +int STD_PROTO(Yap_Unifiable,(Term d0, Term d1)); int STD_PROTO(Yap_IUnify,(register CELL d0,register CELL d1)); /* userpreds.c */ @@ -397,6 +397,8 @@ int STD_PROTO(Yap_SizeGroundTerm,(Term, int)); int STD_PROTO(Yap_IsGroundTerm,(Term)); void STD_PROTO(Yap_InitUtilCPreds,(void)); Int STD_PROTO(Yap_TermHash,(Term, Int, Int, int)); +Int STD_PROTO(Yap_NumberVars,(Term, Int)); +Term STD_PROTO(Yap_UnNumberTerm,(Term)); /* yap.c */ diff --git a/Makefile.in b/Makefile.in index 7f1588a2f..e4e0b704d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -115,6 +115,15 @@ INTERFACE_HEADERS = \ $(srcdir)/include/yap_structs.h \ $(srcdir)/include/YapInterface.h \ $(srcdir)/include/SWI-Prolog.h \ + $(srcdir)/H/TermExt.h \ + $(srcdir)/H/YapTags.h \ + $(srcdir)/H/Tags_32bits.h \ + $(srcdir)/H/Tags_32Ops.h \ + $(srcdir)/H/Tags_32LowTag.h \ + $(srcdir)/H/Tags_64bits.h \ + $(srcdir)/H/Tags_24bits.h \ + $(srcdir)/H/YapTerm.h \ + $(srcdir)/include/YapRegs.h \ $(srcdir)/library/dialect/bprolog/fli/bprolog.h \ $(srcdir)/os/SWI-Stream.h @@ -136,13 +145,7 @@ IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \ $(srcdir)/H/pl-yap.h @ENABLE_WINCONSOLE@ $(srcdir)/os/windows/dirent.h $(srcdir)/os/windows/utf8.h $(srcdir)/os/windows/utf8.c $(srcdir)/os/windows/uxnt.h $(srcdir)/os/windows/mswchar.h $(srcdir)/os/windows/popen.c HEADERS = \ - $(srcdir)/H/TermExt.h \ $(srcdir)/H/Atoms.h \ - $(srcdir)/H/Tags_32bits.h \ - $(srcdir)/H/Tags_32Ops.h \ - $(srcdir)/H/Tags_32LowTag.h \ - $(srcdir)/H/Tags_64bits.h \ - $(srcdir)/H/Tags_24bits.h \ $(srcdir)/H/sshift.h \ $(srcdir)/H/Yap.h \ $(srcdir)/H/Yatom.h \ @@ -407,7 +410,7 @@ all: parms.h startup.yss @ENABLE_WINCONSOLE@ pl-yap@EXEC_SUFFIX@ Makefile: $(srcdir)/Makefile.in -$(srcdir)/H/Yap.h: config.h +$(srcdir)/H/Yap.h: config.h YapTermConfig.h $(srcdir)/H/YapTags.h config.h: parms.h @@ -774,10 +777,12 @@ install_unix: startup.yss libYap.a @ENABLE_JPL@ @INSTALL_DLLS@ (cd packages/jpl; $(MAKE) install) #@ENABLE_JPL@ @INSTALL_DLLS@ (cd packages/pyswip; $(MAKE) install) mkdir -p $(DESTDIR)$(INCLUDEDIR) - $(INSTALL) $(HEADERS) $(DESTDIR)$(INCLUDEDIR) + mkdir -p $(DESTDIR)$(INCLUDEDIR)/src + $(INSTALL) $(HEADERS) $(DESTDIR)$(INCLUDEDIR)/src for h in $(INTERFACE_HEADERS); do $(INSTALL) $$h $(DESTDIR)$(INCLUDEDIR); done - $(INSTALL) config.h $(DESTDIR)$(INCLUDEDIR)/config.h - $(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/parms.h + $(INSTALL) config.h $(DESTDIR)$(INCLUDEDIR)/src/config.h + $(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/src/parms.h + $(INSTALL) YapTermConfig.h $(DESTDIR)$(INCLUDEDIR) @ENABLE_CPLINT@ (cd packages/cplint; $(MAKE) install) @ENABLE_CPLINT@ (cd packages/cplint/approx/simplecuddLPADs; $(MAKE) install) @ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE) install) @@ -859,7 +864,7 @@ TAGS: $(C_SOURCES) $(PL_SOURCES) $(HEADERS) depend: $(HEADERS) $(C_SOURCES) -@if test "$(GCC)" = yes; then\ - $(CC) -MM $(CFLAGS) -I$(srcdir) -I$(srcdir)/include -I$(srcdir)/os $(C_SOURCES) >> Makefile;\ + $(CC) -MM $(CFLAGS) -D__YAP_NOT_INSTALLED__=1 -I$(srcdir) -I$(srcdir)/include -I$(srcdir)/os $(C_SOURCES) >> Makefile;\ else\ makedepend -f - -- $(CFLAGS) -I$(srcdir)/include -- $(C_SOURCES) |\ sed 's|.*/\([^:]*\):|\1:|' >> Makefile ;\ diff --git a/config.h.in b/config.h.in index 19d719fb5..79941dd18 100644 --- a/config.h.in +++ b/config.h.in @@ -135,14 +135,7 @@ /* Define byte order */ #undef WORDS_BIGENDIAN -/* Define sizes of some basic types */ -#undef SIZEOF_INT_P -#undef SIZEOF_INT -#undef SIZEOF_SHORT_INT -#undef SIZEOF_LONG_INT -#undef SIZEOF_LONG_LONG_INT -#undef SIZEOF_FLOAT -#undef SIZEOF_DOUBLE +#include "YapTermConfig.h" /* Define representation of floats */ /* only one of the following shoud be set */ diff --git a/configure b/configure index af1a526c9..b78c7971f 100755 --- a/configure +++ b/configure @@ -2617,6 +2617,8 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers config.h" +ac_config_headers="$ac_config_headers YapTermConfig.h" + mycflags="$CFLAGS" @@ -10860,6 +10862,7 @@ for ac_config_target in $ac_config_targets do case $ac_config_target in "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; + "YapTermConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS YapTermConfig.h" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "GPL/Makefile") CONFIG_FILES="$CONFIG_FILES GPL/Makefile" ;; "library/Makefile") CONFIG_FILES="$CONFIG_FILES library/Makefile" ;; diff --git a/configure.in b/configure.in index 49252c1dd..a2fd80031 100644 --- a/configure.in +++ b/configure.in @@ -45,6 +45,7 @@ dnl EXTRA_LIBS_FOR_SWIDLLS= libs that are required when lding a SWI so AC_INIT(console/yap.c) AC_CONFIG_HEADER(config.h) +AC_CONFIG_HEADER(YapTermConfig.h) dnl store the environment's compilation flags mycflags="$CFLAGS" diff --git a/docs/yap.tex b/docs/yap.tex index dd4d5d2f9..c3de0939b 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -3272,6 +3272,12 @@ compound term. Instantiates each variable in term @var{T} to a term of the form: @code{'$VAR'(@var{I})}, with @var{I} increasing from @var{N1} to @var{Nn}. +@item unnumbervars(@var{T},+@var{NT}) +@findex unnumbervars/2 +@syindex unnumbervars/2 +@cnindex unnumbervars/2 +Replace every @code{'$VAR'(@var{I})} by a free variable. + @item ground(@var{T}) @findex ground/1 @syindex ground/1 @@ -16171,6 +16177,7 @@ The user can create a new uninstantiated variable using the primitive @findex YAP_IsAtomTerm (C-Interface function) @findex YAP_IsPairTerm (C-Interface function) @findex YAP_IsApplTerm (C-Interface function) +@findex YAP_IsCompoundTerm (C-Interface function) The following primitives can be used to discriminate among the different types of non-variable terms: @example @@ -16180,6 +16187,7 @@ of non-variable terms: YAP_Bool YAP_IsAtomTerm(YAP_Term @var{t}) YAP_Bool YAP_IsPairTerm(YAP_Term @var{t}) YAP_Bool YAP_IsApplTerm(YAP_Term @var{t}) + YAP_Bool YAP_IsCompoundTerm(YAP_Term @var{t}) @end example The next primitive gives the type of a Prolog term: @@ -16603,6 +16611,22 @@ The next function succeeds if two terms are variant terms, and returns @end example @noindent +The next functions deal with numbering variables in terms: +@example + int YAP_NumberVars(YAP_Term t, YAP_Int first_number) + YAP_Term YAP_UnNumberVars(YAP_Term t) + int YAP_IsNumberedVariable(YAP_Term t) +@end example +@noindent + +The next one returns the length of a well-formed list @var{t}, or +@code{-1} otherwise: +@example + Int YAP_ListLength(YAP_Term t) +@end example +@noindent + + Last, this function succeeds if two terms are unifiable: @code{=@=/2}: @example diff --git a/include/YapTags.h b/include/YapTags.h deleted file mode 100644 index 587900b54..000000000 --- a/include/YapTags.h +++ /dev/null @@ -1,119 +0,0 @@ -/***********************************************************************/ - - /* - absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var - - with AbsAppl(t) : *CELL -> Term - and RepAppl(t) : Term -> *CELL - - and AbsPair(t) : *CELL -> Term - and RepPair(t) : Term -> *CELL - - and IsIntTerm(t) = ... - and IsAtomTerm(t) = ... - and IsVarTerm(t) = ... - and IsPairTerm(t) = ... - and IsApplTerm(t) = ... - and IsFloatTerm(t) = ... - and IsRefTerm(t) = ... - and IsNonVarTerm(t) = ! IsVar(t) - and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t) - and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t) - and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t) - - and MkIntTerm(n) = ... - and MkFloatTerm(f) = ... - and MkAtomTerm(a) = ... - and MkVarTerm(r) = ... - and MkApplTerm(f,n,args) = ... - and MkPairTerm(hd,tl) = ... - and MkRefTerm(R) = ... - - and PtrOfTerm(t) : Term -> CELL * = ... - and IntOfTerm(t) : Term -> int = ... - and FloatOfTerm(t) : Term -> flt = ... - and AtomOfTerm(t) : Term -> Atom = ... - and VarOfTerm(t) : Term -> *Term = .... - and HeadOfTerm(t) : Term -> Term = ... - and TailOfTerm(t) : Term -> Term = ... - and FunctorOfTerm(t) : Term -> Functor = ... - and ArgOfTerm(i,t) : Term -> Term= ... - and RefOfTerm(t) : Term -> DBRef = ... - - */ - -/* - YAP can use several different tag schemes, according to the kind of - machine we are experimenting with. -*/ - -#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME) - -#include "Tags_32bits.h" - -#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */ - -/* AIX will by default place mmaped segments at 0x30000000. This is - incompatible with the high tag scheme. Linux-ELF also does not like - if you place things in the lower addresses (power to the libc people). -*/ - -#if defined(__APPLE__) -/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */ -#undef USE_DL_MALLOC -#ifndef USE_SYSTEM_MALLOC -#define USE_SYSTEM_MALLOC 1 -#endif -#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__) -#define USE_LOW32_TAGS 1 -#endif - -#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) - -#include "Tags_32Ops.h" - -#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */ - -#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS) - -#include "Tags_32LowTag.h" - -#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */ - -#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) - -#include "Tags_64bits.h" - -#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */ - -#if !LONG_ADDRESSES - -#include "Tags_24bits.h" - -#endif /* !LONG_ADDRESSES */ - -#ifdef TAG_LOW_BITS_32 - -#if !GC_NO_TAGS -#define MBIT 0x80000000 -#define RBIT 0x40000000 - -#if IN_SECOND_QUADRANT -#define INVERT_RBIT 1 /* RBIT is 1 by default */ -#endif -#endif /* !GC_NO_TAGS */ - -#else - -#if !GC_NO_TAGS -#if defined(YAPOR_SBA) && defined(__linux__) -#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */ -#else -#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */ -#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */ -#endif -#endif /* !GC_NO_TAGS */ - -#endif - -#define TermSize sizeof(Term) diff --git a/library/Makefile.in b/library/Makefile.in index e5be0239a..1e135fd88 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -101,6 +101,7 @@ DIALECT_SWI= \ DIALECT_BP= \ $(srcdir)/dialect/bprolog/actionrules.pl \ + $(srcdir)/dialect/bprolog/arrays.yap \ $(srcdir)/dialect/bprolog/compile_foreach.pl \ $(srcdir)/dialect/bprolog/foreach.pl \ $(srcdir)/dialect/bprolog/hashtable.yap @@ -109,6 +110,7 @@ install: $(PROGRAMS) install_myddas mkdir -p $(DESTDIR)$(SHAREDIR)/Yap mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect/swi + mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect/bprolog for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done for p in $(DIALECT_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect; done for p in $(DIALECT_SWI); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect/swi; done From f8e3c7d34706dbdac87ae396cb5235169161c223 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 3 Nov 2011 07:56:52 +0900 Subject: [PATCH 36/40] for external code needing access to YAP internals. --- YapTermConfig.h.in | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 YapTermConfig.h.in diff --git a/YapTermConfig.h.in b/YapTermConfig.h.in new file mode 100644 index 000000000..0172f92cc --- /dev/null +++ b/YapTermConfig.h.in @@ -0,0 +1,9 @@ +/* Define sizes of some basic types */ +#undef SIZEOF_INT_P +#undef SIZEOF_INT +#undef SIZEOF_SHORT_INT +#undef SIZEOF_LONG_INT +#undef SIZEOF_LONG_LONG_INT +#undef SIZEOF_FLOAT +#undef SIZEOF_DOUBLE + From e283f6406a60416cd880d757b0d62f606c3c9c64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Fri, 4 Nov 2011 11:41:35 +0900 Subject: [PATCH 37/40] fix Yap_compare_terms for 64 bit code. --- C/cmppreds.c | 7 ++++--- C/sort.c | 4 ++-- H/Yapproto.h | 2 +- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/C/cmppreds.c b/C/cmppreds.c index 9402f82c7..d750fe84c 100644 --- a/C/cmppreds.c +++ b/C/cmppreds.c @@ -317,8 +317,9 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */ return 1; return -1; } else { - if (IsIntTerm(t2)) + if (IsIntTerm(t2)) { return IntOfTerm(t1) - IntOfTerm(t2); + } if (IsFloatTerm(t2)) { return 1; } @@ -441,9 +442,9 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */ } } -int Yap_compare_terms(CELL d0, CELL d1) +Int Yap_compare_terms(Term d0, Term d1) { - return (compare(Deref(d0),Deref(d1))); + return compare(Deref(d0),Deref(d1)); } static Int diff --git a/C/sort.c b/C/sort.c index 0f78c6fa5..6b2d06617 100644 --- a/C/sort.c +++ b/C/sort.c @@ -267,14 +267,14 @@ Int compact_mergesort(CELL *pt, Int size, int my_p) while (pt_left < end_pt_left && pt_right < end_pt_right) { /* if the element to the left is larger than the one to the right */ Int cmp = Yap_compare_terms(pt_left[0], pt_right[0]); - if (cmp < 0) { + if (cmp < (Int)0) { /* copy the one to the left */ pt[0] = pt_left[0]; /* and avance the two pointers */ pt += 2; size ++; pt_left += 2; - } else if (cmp == 0) { + } else if (cmp == (Int)0) { /* otherwise, just skip one of them, anyone */ pt_left += 2; } else { diff --git a/H/Yapproto.h b/H/Yapproto.h index 54e63a568..d61c5813a 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -140,7 +140,7 @@ void STD_PROTO(Yap_AssertzClause,(struct pred_entry *, yamop *)); /* cmppreds.c */ -int STD_PROTO(Yap_compare_terms,(Term,Term)); +Int STD_PROTO(Yap_compare_terms,(Term,Term)); void STD_PROTO(Yap_InitCmpPreds,(void)); /* compiler.c */ From fc8b265b66a459356561dad0e3ac7b88f4cb6ab0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Fri, 4 Nov 2011 02:51:52 +0000 Subject: [PATCH 38/40] ifix buildops --- H/findclause.h | 3 ++- H/headclause.h | 3 ++- misc/buildops | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/H/findclause.h b/H/findclause.h index 4a5c4199a..3ed05df81 100644 --- a/H/findclause.h +++ b/H/findclause.h @@ -671,7 +671,8 @@ break; case _get_bigint: if (is_regcopy(myregs, nofregs, cl->u.xN.x)) { - clause->Tag = cl->u.xN.b; + clause->Tag = AbsAppl((CELL *)FunctorBigInt); + clause->u.t_ptr = (CELL)NULL; return; } cl = NEXTOP(cl,xN); diff --git a/H/headclause.h b/H/headclause.h index a24f4df35..efdec61d6 100644 --- a/H/headclause.h +++ b/H/headclause.h @@ -562,7 +562,8 @@ break; case _get_bigint: if (iarg == cl->u.xN.x) { - clause->Tag = cl->u.xN.b; + clause->Tag = AbsAppl((CELL *)FunctorBigInt); + clause->u.t_ptr = (CELL)NULL; return; } cl = NEXTOP(cl,xN); diff --git a/misc/buildops b/misc/buildops index 41343394b..39dc05a96 100644 --- a/misc/buildops +++ b/misc/buildops @@ -877,7 +877,7 @@ opinfo("gl_void_vary",[bind("y","AbsPair(NULL)",workpc=currentop),new("y")]). opinfo("get_struct",[bind("x","AbsAppl((CELL *)cl->u.xfa.f)",workpc=nextop)]). opinfo("get_float",[bind("x","AbsAppl((CELL *)FunctorDouble)",t_ptr="d")]). opinfo("get_longint",[bind("x","AbsAppl((CELL *)FunctorLongInt)",t_ptr="i")]). -opinfo("get_bigint",[bind("x","b",[])]). +opinfo("get_bigint",[bind("x","AbsAppl((CELL *)FunctorBigInt)",t_ptr=[])]). opinfo("copy_idb_term",[logical]). opinfo("unify_idb_term",[logical]). opinfo("put_atom",[new("x")]). From 4af0f47b7ff6dee92b669457b1be1fd49dbd06a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Fri, 4 Nov 2011 09:28:09 +0000 Subject: [PATCH 39/40] add this file to repository. --- H/YapTerm.h | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 137 insertions(+) create mode 100644 H/YapTerm.h diff --git a/H/YapTerm.h b/H/YapTerm.h new file mode 100644 index 000000000..6b9a52831 --- /dev/null +++ b/H/YapTerm.h @@ -0,0 +1,137 @@ +/************************************************************************* +* * +* YAP Prolog %W% %G% * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * +* * +************************************************************************** +* * +* File: Yap.h * +* mods: * +* comments: abstract type definitions for YAP * +* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ * +*************************************************************************/ + +#ifndef _YAP_NOT_INSTALLED_ +#include "YapTermConfig.h" + +typedef void *Functor; +typedef void *Atom; + +#endif + +#ifndef EXTERN +#define EXTERN extern +#endif + +/* defines integer types Int and UInt (unsigned) with the same size as a ptr +** and integer types Short and UShort with half the size of a ptr */ + +#if SIZEOF_INT_P==4 + +#if SIZEOF_INT==4 +/* */ typedef int Int; +/* */ typedef unsigned int UInt; + +#define Int_FORMAT "%d" +#define UInt_FORMAT "%u" + +#elif SIZEOF_LONG_INT==4 +/* */ typedef long int Int; +/* */ typedef unsigned long int UInt; + +#define Int_FORMAT "%ld" +#define UInt_FORMAT "%lu" + +#else +#error Yap require integer types of the same size as a pointer +#endif + +#if SIZEOF_SHORT_INT==2 +/* */ typedef short int Short; +/* */ typedef unsigned short int UShort; + +#else +# error Yap requires integer types half the size of a pointer +#endif + +#elif SIZEOF_INT_P==8 + +#if SIZEOF_INT==8 +/* */ typedef int Int; +/* */ typedef unsigned int UInt; + +#define Int_FORMAT "%d" +#define UInt_FORMAT "%u" + +#elif SIZEOF_LONG_INT==8 +/* */ typedef long int Int; +/* */ typedef unsigned long int UInt; + +#define Int_FORMAT "%ld" +#define UInt_FORMAT "%lu" + +# elif SIZEOF_LONG_LONG_INT==8 +/* */ typedef long long int Int; +/* */ typedef unsigned long long int UInt; + +#define Int_FORMAT "%I64d" +#define UInt_FORMAT "%I64u" + +# else +# error Yap requires integer types of the same size as a pointer +# endif + +# if SIZEOF_SHORT_INT==4 +/* */ typedef short int Short; +/* */ typedef unsigned short int UShort; + +# elif SIZEOF_INT==4 +/* */ typedef int Short; +/* */ typedef unsigned int UShort; + +# else +# error Yap requires integer types half the size of a pointer +# endif + +#else + +# error Yap requires pointers of size 4 or 8 + +#endif + +typedef UInt CELL; +typedef UShort BITS16; +typedef Short SBITS16; +typedef UInt BITS32; + +#define WordSize sizeof(BITS16) +#define CellSize sizeof(CELL) +#define SmallSize sizeof(SMALLUNSGN) + +/************************************************************************************************* + type casting macros +*************************************************************************************************/ + + +typedef CELL Term; + +/* */ typedef double Float; + +#if SIZEOF_INT Date: Fri, 4 Nov 2011 09:28:33 +0000 Subject: [PATCH 40/40] iunnumbervars may be copying terms from outside the stacks, so don't share unless we know we share. --- C/c_interface.c | 3 ++- C/utilpreds.c | 28 +++++++++++++++------------- H/Yapproto.h | 2 +- 3 files changed, 18 insertions(+), 15 deletions(-) diff --git a/C/c_interface.c b/C/c_interface.c index 59a10d15f..cac674149 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -3898,7 +3898,8 @@ YAP_NumberVars(Term t, Int nbv) { Term YAP_UnNumberVars(Term t) { - return Yap_UnNumberTerm(t); + /* don't allow sharing of ground terms */ + return Yap_UnNumberTerm(t, FALSE); } int diff --git a/C/utilpreds.c b/C/utilpreds.c index 981c81eb7..b5f4dfee4 100644 --- a/C/utilpreds.c +++ b/C/utilpreds.c @@ -4406,7 +4406,7 @@ Yap_NumberVars( Term inp, Int numbv ) /* numbervariables in term t */ } static Int -p_numbervars(void) +p_numbervars( USES_REGS1 ) { Term t2 = Deref(ARG2); Int out; @@ -4425,13 +4425,13 @@ p_numbervars(void) } static int -unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) +unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow, int share USES_REGS) { struct cp_frame *to_visit0, *to_visit = (struct cp_frame *)Yap_PreAllocCodeSpace(); CELL *HB0 = HB; tr_fr_ptr TR0 = TR; - int ground = TRUE; + int ground = share; Int max = -1; HB = HLow; @@ -4479,7 +4479,7 @@ unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) to_visit ++; } #endif - ground = TRUE; + ground = share; pt0 = ap2 - 1; pt0_end = ap2 + 1; ptf = H; @@ -4555,7 +4555,7 @@ unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) to_visit ++; } #endif - ground = (f != FunctorMutable); + ground = (f != FunctorMutable) && share; d0 = ArityOfFunctor(f); pt0 = ap2; pt0_end = ap2 + d0; @@ -4574,6 +4574,7 @@ unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) } derefa_body(d0, ptd0, unnumber_term_unk, unnumber_term_nvar); + /* this should never happen ? */ ground = FALSE; *ptf++ = (CELL) ptd0; } @@ -4647,7 +4648,7 @@ unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS) static Term -UnnumberTerm(Term inp, UInt arity USES_REGS) { +UnnumberTerm(Term inp, UInt arity, int share USES_REGS) { Term t = Deref(inp); tr_fr_ptr TR0 = TR; @@ -4667,7 +4668,7 @@ UnnumberTerm(Term inp, UInt arity USES_REGS) { H += 2; { int res; - if ((res = unnumber_complex_term(ap-1, ap+1, Hi, Hi PASS_REGS)) < 0) { + if ((res = unnumber_complex_term(ap-1, ap+1, Hi, Hi, share PASS_REGS)) < 0) { H = Hi; if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) return FALSE; @@ -4699,7 +4700,7 @@ UnnumberTerm(Term inp, UInt arity USES_REGS) { } else { int res; - if ((res = unnumber_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0 PASS_REGS)) < 0) { + if ((res = unnumber_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0, share PASS_REGS)) < 0) { H = HB0; if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L) return FALSE; @@ -4714,14 +4715,15 @@ UnnumberTerm(Term inp, UInt arity USES_REGS) { } Term -Yap_UnNumberTerm(Term inp) { +Yap_UnNumberTerm(Term inp, int share) { CACHE_REGS - return UnnumberTerm(inp, 0 PASS_REGS); + return UnnumberTerm(inp, 0, share PASS_REGS); } -static int -p_unnumbervars(void) { - return Yap_unify(Yap_UnNumberTerm(ARG1), ARG2); +static Int +p_unnumbervars( USES_REGS1 ) { + /* this should be a standard Prolog term, so we allow sharing? */ + return Yap_unify(Yap_UnNumberTerm(ARG1, FALSE PASS_REGS), ARG2); } void Yap_InitUtilCPreds(void) diff --git a/H/Yapproto.h b/H/Yapproto.h index d61c5813a..34af15026 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -398,7 +398,7 @@ int STD_PROTO(Yap_IsGroundTerm,(Term)); void STD_PROTO(Yap_InitUtilCPreds,(void)); Int STD_PROTO(Yap_TermHash,(Term, Int, Int, int)); Int STD_PROTO(Yap_NumberVars,(Term, Int)); -Term STD_PROTO(Yap_UnNumberTerm,(Term)); +Term STD_PROTO(Yap_UnNumberTerm,(Term, int)); /* yap.c */