diff --git a/H/Yapproto.h b/H/Yapproto.h index 44eca3def..3526f415f 100755 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -175,6 +175,7 @@ extern int Yap_DBTrailOverflow(void); extern CELL Yap_EvalMasks(Term, CELL *); extern void Yap_InitBackDB(void); extern void Yap_InitDBPreds(void); +extern void Yap_InitDBLoadPreds(void); /* errors.c */ #if DEBUG diff --git a/H/absmi.h b/H/absmi.h index 01884cc3d..2f561bde8 100755 --- a/H/absmi.h +++ b/H/absmi.h @@ -31,6 +31,12 @@ #define register #endif + +#if TABLING +#define FROZEN_STACKS 1 +//#define MULTIPLE_STACKS 1 +#endif + /*************************************************************** * Macros for register manipulation * ***************************************************************/ diff --git a/H/amidefs.h b/H/amidefs.h index bc6a33945..887098430 100644 --- a/H/amidefs.h +++ b/H/amidefs.h @@ -48,6 +48,7 @@ typedef struct regstore_t *regstruct_ptr; #endif + typedef Int (*CPredicate)(CACHE_TYPE1); typedef Int (*CmpPredicate)(Term, Term); diff --git a/H/trim_trail.h b/H/trim_trail.h index 1910c20b7..988830202 100644 --- a/H/trim_trail.h +++ b/H/trim_trail.h @@ -1,17 +1,17 @@ #ifdef FROZEN_STACKS + +#define RESET_TRAIL_ENTRY(pt) { TrailTerm(pt) = (CELL)(pt); TrailVal(pt) = (CELL)(pt); } { - tr_fr_ptr pt0, pt1, pbase, ptop; - pbase = B->cp_tr, ptop = TR; - pt0 = pt1 = TR - 1; + tr_fr_ptr pt1, pbase; + pbase = B->cp_tr; + pt1 = TR - 1; while (pt1 >= pbase) { BEGD(d1); d1 = TrailTerm(pt1); if (IsVarTerm(d1)) { - if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) { - TrailTerm(pt0) = d1; - TrailVal(pt0) = TrailVal(pt1); - pt0--; + if (d1 >= (CELL)HBREG && d1 < Unsigned(HR)) { + RESET_TRAIL_ENTRY(pt1); } pt1--; } else if (IsPairTerm(d1)) { @@ -28,14 +28,14 @@ /* skip, this is a problem because we lose information, namely active references */ pt1 = (tr_fr_ptr)pt; - } else if (IN_BETWEEN(H0, pt, HR) && IsApplTerm(HeadOfTerm(d1))) { + } else if (IN_BETWEEN(H0, pt, LCL0) && IsApplTerm(HeadOfTerm(d1))) { Term t = HeadOfTerm(d1); Functor f = FunctorOfTerm(t); if (f == FunctorBigInt) { Int tag = Yap_blob_tag(t); GLOBAL_OpaqueHandlers[tag].cut_handler(d1); - } else { - pt0--; + RESET_TRAIL_ENTRY(pt1); + } pt1--; continue; @@ -48,6 +48,7 @@ LOCK(ap->PELock); DEC_CLREF_COUNT(cl); + RESET_TRAIL_ENTRY(pt1); cl->ClFlags &= ~InUseMask; erase = (cl->ClFlags & (ErasedMask | DirtyMask)) && !(cl->ClRefCount); if (erase) { @@ -59,43 +60,23 @@ Yap_CleanUpIndex(cl); } UNLOCK(ap->PELock); - } else { - TrailTerm(pt0) = d1; - TrailVal(pt0) = TrailVal(pt1); - pt0--; } pt1--; } else if (IsApplTerm(d1)) { if (IN_BETWEEN(HBREG, RepAppl(d1), B->cp_b)) { - /* deterministic binding to multi-assignment variable */ - pt1 -= 2; + RESET_TRAIL_ENTRY(pt1); + pt1--; + RESET_TRAIL_ENTRY(pt1); +/* deterministic binding to multi-assignment variable */ + pt1 --; } else { - TrailVal(pt0) = TrailVal(pt1); - TrailTerm(pt0) = d1; - TrailVal(pt0 - 1) = TrailVal(pt1 - 1); - TrailTerm(pt0 - 1) = TrailTerm(pt1 - 1); - pt0 -= 2; pt1 -= 2; } } else { - TrailTerm(pt0) = d1; - TrailVal(pt0) = TrailVal(pt1); - pt0--; - pt1--; + pt1--; } ENDD(d1); } - if (pt0 != pt1) { - int size; - pt0++; - size = ptop - pt0; - memmove(pbase, pt0, size * sizeof(struct trail_frame)); - if (ptop != TR) { - memmove(pbase + size, ptop, (TR - ptop) * sizeof(struct trail_frame)); - size += (TR - ptop); - } - TR = pbase + size; - } } #else { diff --git a/packages/ProbLog/problog.yap b/packages/ProbLog/problog.yap index 020a8a03c..e97fcaea3 100644 --- a/packages/ProbLog/problog.yap +++ b/packages/ProbLog/problog.yap @@ -845,7 +845,7 @@ term_expansion_intern(Head :: Goal,Module,problog:ProbFact) :- % handles probabilistic facts term_expansion_intern(P :: Goal,Module,problog:ProbFact) :- - copy_term((P,Goal),(P_Copy,Goal_Copy)), + copy_term((P,Goal),(P_Copy,Goal_Copy)), functor(Goal, Name, Arity), atomic_concat([problog_,Name],ProblogName), Goal =.. [Name|Args], diff --git a/packages/ProbLog/problog/lbdd.yap b/packages/ProbLog/problog/lbdd.yap index 8a2ca22e8..182b20133 100644 --- a/packages/ProbLog/problog/lbdd.yap +++ b/packages/ProbLog/problog/lbdd.yap @@ -91,6 +91,7 @@ gradient(QueryID, g, Slope) :- query_probabilities( DBDD, Prob) :- DBDD = bdd(Dir, Tree, _MapList), findall(P, evalp(Tree,P), [Prob0]), + % nonvar(Prob0), (Dir == 1 -> Prob0 = Prob ; Prob is 1.0-Prob0). evalp( Tree, Prob0) :- @@ -104,7 +105,7 @@ query_gradients(bdd(Dir, Tree, MapList),I,IProb,Grad) :- evalp( pn(P, _-X, PL, PR), _,P ):- P is X*PL+ (1.0-X)*(1.0-PR). -evalp( pp(P, _-X, PL, PR), _,P ):- +evalp( pp(P, _-X, PL, PR), _,P ):- P is X*PL+ (1.0-X)*PR. evalg( I, pp(P-G, J-X, L, R), _, G ):- diff --git a/packages/ProbLog/problog_examples/learn_graph_lbdd.pl b/packages/ProbLog/problog_examples/learn_graph_lbdd.pl index c91e644ac..2fccd680b 100644 --- a/packages/ProbLog/problog_examples/learn_graph_lbdd.pl +++ b/packages/ProbLog/problog_examples/learn_graph_lbdd.pl @@ -14,20 +14,9 @@ % will run 20 iterations of learning with default settings %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -:- use_module('../problog_lbfgs'). +:- use_module('../problog_learning_lbdd'). - :- if(true). - - :- use_module('kbgraph'). - - -%%%% -% background knowledge -%%%% -% definition of acyclic path using list of visited nodes - -:- else. :- Query=path(X,Y), set_problog_flag(init_method,(Query,K,Bdd,problog:problog_exact_lbdd(Query,Bdd))). @@ -48,7 +37,6 @@ edge(X,Y) :- dir_edge(X,Y). absent(_,[]). absent(X,[Y|Z]):-X \= Y, absent(X,Z). -:- endif. %%%% % probabilistic facts diff --git a/packages/ProbLog/problog_lbfgs.yap b/packages/ProbLog/problog_lbfgs.yap index 722ef9bff..314dbf00f 100644 --- a/packages/ProbLog/problog_lbfgs.yap +++ b/packages/ProbLog/problog_lbfgs.yap @@ -553,7 +553,7 @@ empty_bdd_directory. init_queries :- empty_bdd_directory, format_learning(2,'Build BDDs for examples~n',[]), - forall(user:test_example(ID,Query,_Prob,_),init_one_query(ID,Query,test)), + forall(user:test_example(ID,Query,_Prob,_),init_one_query(ID,Query,test)), forall(user:example(ID,Query,_Prob,_),init_one_query(ID,Query,training)). bdd_input_file(Filename) :- @@ -835,7 +835,7 @@ update_values :- % delete old values %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% retractall(query_probability_intern(_,_)), - retractall(query_gradient_intern(_,_,_,_)), + retractall(query_gradient_intern(_,_,_,_)), assertz(values_correct). @@ -847,7 +847,7 @@ update_values :- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % start calculate gradient %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -user:evaluate(LLH_Training_Queries, X,Grad,N,_,_) :- +user:evaluate(LLH_Training_Queries, X,Grad,N,_,_) :- %Handle = user_error, N1 is N-1, forall(between(0,N1,I),(Grad[I]<==0.0)), @@ -893,13 +893,11 @@ compute_gradient( Grad, X, Slope, LL) :- BDD = bdd(_,_,MapList), MapList = [_|_], bind_maplist(MapList, Slope, X), -%writeln(QueryID:MapList), query_probabilities( BDD, BDDProb), (isnan(BDDProb) -> writeln((nan::QueryID)), fail;true), -writeln(BDDProb), LL is (BDDProb-QueryProb)*(BDDProb-QueryProb), forall( - query_gradients(BDD,I,IProb,GradValue), + query_gradients(BDD,I,IProb,GradValue), gradient_pair(BDDProb, QueryProb, Grad, GradValue, I, IProb) ). @@ -925,8 +923,9 @@ wrap( _X, _Grad, _GradCount). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% user:progress(FX,_X,_G, _X_Norm,_G_Norm,_Step,_N,_CurrentIteration,_Ls,-1) :- FX < 0, !, - format('stopped on bad FX=~4f~n',[FX]). + format('Bad FX=~4f~n',[FX]). user:progress(FX,X,G,X_Norm,G_Norm,Step,_N, LBFGSIteration,Ls,0) :- +writeln(fx=FX), problog_flag(sigmoid_slope,Slope), save_state(X, Slope, G), logger_set_variable(mse_trainingset, FX), @@ -946,22 +945,6 @@ save_state(X,Slope,_Grad) :- tunable_fact(FactID,_GroundTruth), set_tunable(FactID,Slope,X), fail. -save_state(X, Slope, _) :- - user:example(QueryID,_Query,_QueryProb), - recorded(QueryID,BDD,_), - BDD = bdd(_,_,MapList), - bind_maplist(MapList, Slope, X), - query_probabilities( BDD, BDDProb), - assert( query_probability_intern(QueryID,BDDProb)), - fail. -save_state(X, Slope, _) :- - user:test_example(QueryID,_Query,_QueryProb), - recorded(QueryID,BDD,_), - BDD = bdd(_,_,MapList), - bind_maplist(MapList, Slope, X), - query_probabilities( BDD, BDDProb), - assert( query_probability_intern(QueryID,BDDProb)), - fail. save_state(_X, _Slope, _). %======================================================================== diff --git a/packages/ProbLog/problog_learning.yap b/packages/ProbLog/problog_learning.yap index 019463a57..9d4c70725 100644 --- a/packages/ProbLog/problog_learning.yap +++ b/packages/ProbLog/problog_learning.yap @@ -710,7 +710,7 @@ update_values :- %= %======================================================================== - listing( + update_query_cleanup(QueryID) :- ( (query_is_similar(QueryID,_) ; query_is_similar(_,QueryID)) -> @@ -893,7 +893,6 @@ ground_truth_difference :- %= %= -Float %======================================================================== - mse_trainingset_only_for_linesearch(MSE) :- update_values, diff --git a/packages/ProbLog/problog_learning_lbdd.yap b/packages/ProbLog/problog_learning_lbdd.yap index a09dc0da1..51cdac6dc 100644 --- a/packages/ProbLog/problog_learning_lbdd.yap +++ b/packages/ProbLog/problog_learning_lbdd.yap @@ -228,6 +228,7 @@ :- use_module('problog/utils_lbdd'). :- use_module('problog/utils'). :- use_module('problog/tabling'). +:- use_module('problog/lbdd'). % used to indicate the state of the system :- dynamic(values_correct/0). diff --git a/packages/yap-lbfgs/lbfgs.pl b/packages/yap-lbfgs/lbfgs.pl index f5c1a7624..173d56e86 100644 --- a/packages/yap-lbfgs/lbfgs.pl +++ b/packages/yap-lbfgs/lbfgs.pl @@ -24,6 +24,7 @@ lbfgs_initialize/4, lbfgs_run/3, + lbfgs_fx/1, lbfgs_finalize/1, lbfgs_set_parameter/2, @@ -180,7 +181,8 @@ lbfgs_finalize(_N). run the algorithm. output the final score of the function being optimised */ lbfgs_run(N,X,FX) :- - lbfgs(N,X, FX). + lbfgs(N,X), + lbfgs_fx(FX). diff --git a/packages/yap-lbfgs/yap_lbfgs.c b/packages/yap-lbfgs/yap_lbfgs.c index faf493e28..bdf7d809e 100644 --- a/packages/yap-lbfgs/yap_lbfgs.c +++ b/packages/yap-lbfgs/yap_lbfgs.c @@ -35,7 +35,7 @@ X_API void init_lbfgs_predicates(void); YAP_Functor fevaluate, fprogress, fmodule, ffloats; YAP_Term tuser; -lbfgsfloatval_t *x_p; +lbfgsfloatval_t *x_p, f_x; static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x, lbfgsfloatval_t *g_tmp, const int n, @@ -43,7 +43,7 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x, YAP_Term call; YAP_Bool result; lbfgsfloatval_t rc=0.0; - YAP_Term v=YAP_MkVarTerm(), t1, t12; + YAP_Term t12; YAP_Term t[6], t2[2]; YAP_Term t_0 = YAP_MkIntTerm((YAP_Int)&rc); @@ -60,8 +60,6 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x, t2[1] = YAP_MkApplTerm(fevaluate, 6, t); call = YAP_MkApplTerm(fmodule, 2, t2); - - int sl = YAP_InitSlot(v); // lbfgs_status=LBFGS_STATUS_CB_EVAL; result = YAP_RunGoalOnce(call); // lbfgs_status=LBFGS_STATUS_RUNNING; @@ -72,8 +70,6 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x, return FALSE; } YAP_ShutdownGoal(true); - YAP_RecoverSlots(1, sl); - fprintf(stderr,"%gxo\n",rc); return rc; } @@ -183,7 +179,7 @@ value will terminate the optimization process. */ static YAP_Bool p_lbfgs(void) { YAP_Term t1 = YAP_ARG1, t; - int n, sl; + int n; lbfgsfloatval_t *x; lbfgsfloatval_t fx; @@ -196,7 +192,6 @@ static YAP_Bool p_lbfgs(void) { if (n < 1) { return FALSE; } - sl = YAP_InitSlot(YAP_ARG3); if (!x_p) x_p = lbfgs_malloc(n+1); @@ -206,15 +201,17 @@ static YAP_Bool p_lbfgs(void) { lbfgs_parameter_t *param = &parms; void *ui = NULL; //(void *)YAP_IntOfTerm(YAP_ARG4); int ret = lbfgs(n, x, &fx, evaluate, progress, ui, param); - t = YAP_GetFromSlot(sl); - YAP_Unify(t, YAP_MkFloatTerm(fx)); - YAP_RecoverSlots(1, sl); - if (ret == 0) + f_x = fx; +if (ret == 0) return true; fprintf(stderr, "optimization terminated with code %d\n ",ret); return true; } +static YAP_Bool lbfgs_fx(void) { + return YAP_Unify(YAP_ARG1, YAP_MkFloatTerm(f_x)); +} + static YAP_Bool lbfgs_grab(void) { int n = YAP_IntOfTerm(YAP_ARG1); @@ -468,8 +465,9 @@ X_API void init_lbfgs_predicates(void) { lbfgs_parameter_init(&parms); YAP_UserCPredicate("lbfgs_grab", lbfgs_grab, 2); - YAP_UserCPredicate("lbfgs", p_lbfgs, 3); - YAP_UserCPredicate("lbfgs_release", lbfgs_release, 1); + YAP_UserCPredicate("lbfgs", p_lbfgs, 2); + YAP_UserCPredicate("lbfgs_release", lbfgs_release, 1); + YAP_UserCPredicate("lbfgs_fx", lbfgs_fx, 1); YAP_UserCPredicate("lbfgs_defaults", lbfgs_defaults, 0); diff --git a/pl/consult.yap b/pl/consult.yap index 611eac220..248925ced 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -1011,7 +1011,7 @@ prolog_load_context(file, FileName) :- ). prolog_load_context(module, X) :- '__NB_getval__'('$consulting_file', _, fail), - 'current_module'(X). + current_source_module(X,X). prolog_load_context(source, F0) :- ( source_location(F0, _) /*, '$input_context'(Context), diff --git a/pl/imports.yap b/pl/imports.yap index 28a4e9c06..466be0cd2 100644 --- a/pl/imports.yap +++ b/pl/imports.yap @@ -35,20 +35,17 @@ fail. % parent module mechanism %% system has priority '$get_predicate_definition'(_ImportingMod:G,prolog:G) :- - nonvar(G), - '$pred_exists'(G,prolog). + nonvar(G). %% I am there, no need to import '$get_predicate_definition'(Mod:Pred,Mod:Pred) :- - nonvar(Pred), - '$pred_exists'(Pred, Mod). + nonvar(Pred). %% export table '$get_predicate_definition'(ImportingMod:G,ExportingMod:G0) :- recorded('$import','$import'(ExportingMod,ImportingMod,G0,G,_,_),_). %% parent/user -'$get_predicate_definition'(ImportingMod:G,ExportingMod:G0) :- +'$get_predicate_definition'(ImportingMod:G,PMod:G) :- ( '$parent_module'(ImportingMod, PMod) ; PMod = user ), - ImportingMod \= PMod, - '$get_predicate_definition'(PMod:G, ExportingMod:G0). + ImportingMod \= PMod. %% autoload` %'$get_predicate_definition'(ImportingMod:G,ExportingMod:G) :- % current_prolog_flag(autoload, true), @@ -57,22 +54,25 @@ fail. '$predicate_definition'(Imp:Pred,Exp:NPred) :- '$predicate_definition'(Imp:Pred,[],Exp:NPred), + '$pred_exists'(NPred,Exp), %writeln((Imp:Pred -> Exp:NPred )). !. '$one_predicate_definition'(Imp:Pred,Exp:NPred) :- - '$predicate_definition'(Imp:Pred,[],Exp:NPred), + '$get_predicate_definition'(Imp:Pred,[],Exp:NPred), + '$pred_exists'(NPred,Exp), %writeln((Imp:Pred -> Exp:NPred )). !. '$one_predicate_definition'(Exp:Pred,Exp:Pred). '$predicate_definition'(M0:Pred0,Path,ModF:PredF) :- '$get_predicate_definition'(M0:Pred0, Mod:Pred), - \+ lists:member(Mod:Pred,Path), ( - '$predicate_definition'(Mod:Pred,[Mod:Pred|Path],ModF:PredF) + '$pred_exists'(Pred,Mod), Mod = ModF, Pred = PredF ; - Mod = ModF, Pred = PredF + \+ lists:member(Mod:Pred,Path), + '$predicate_definition'(Mod:Pred,[Mod:Pred|Path], ModF:PredF) + ). % diff --git a/pl/meta.yap b/pl/meta.yap index 8452ab833..b1be8e6b9 100644 --- a/pl/meta.yap +++ b/pl/meta.yap @@ -405,6 +405,10 @@ meta_predicate(P) :- '$expand_goals'(B,B1,BO,HM,SM,BM,HVars), '$expand_goals'(C,C1,CO,HM,SM,BM,HVars), '$clean_cuts'(AO0, DCP, AO). +'$expand_goals'(forall(A,B), forall(A1,B1), +(A0 , ( B0 -> fail ; true ) -> fail; true ),HM,SM,BM,HVars) :- !, + '$expand_goals'(A,A1,AO,HM,SM,BM,HVars), + '$expand_goals'(B,B1,BO,HM,SM,BM,HVars). '$expand_goals'((A*->B;C),(A1*->B1;C1), ('$current_choice_point'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !, '$expand_goals'(A,A1,AO0,HM,SM,BM,HVars), diff --git a/pl/preds.yap b/pl/preds.yap index acb9fe7b1..e84452525 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -490,7 +490,7 @@ current_predicate(A0,T0) :- '$current_predicate'(A,M,T,_), functor(T, A, _) ; - '$get_predicate_definition'(M:T,M1:_T1), + '$predicate_definition'(M:T,M1:_T1), M\=M1, functor(T, A, _) ). diff --git a/pl/top.yap b/pl/top.yap index 9e7c28e16..29f8e96b8 100644 --- a/pl/top.yap +++ b/pl/top.yap @@ -602,7 +602,7 @@ write_query_answer( Bindings ) :- expand_goal(M:G, NG), must_be_callable(NG), - '$yap_strip_module'(NG,NM,NC), + '$yap_strip_module'(M:NG,NM,NC), '$call'(NC,CP,G0,NM). '$call'((X,Y),CP,G0,M) :- !, '$call'(X,CP,G0,M), @@ -614,8 +614,11 @@ write_query_answer( Bindings ) :- '$call'(Y,CP,G0,M) ). '$call'((X*->Y),CP,G0,M) :- !, - '$call'(X,CP,G0,M), - '$call'(Y,CP,G0,M). + ( + '$call'(X,CP,G0,M) + *-> + '$call'(Y,CP,G0,M) + ). '$call'((X->Y; Z),CP,G0,M) :- !, ( '$call'(X,CP,G0,M) @@ -671,6 +674,13 @@ write_query_answer( Bindings ) :- '$call'(X,CP,G0,M) ). '$call'(!, CP, _G0, _m) :- !, '$$cut_by'(CP). +'$call'(forall(X,Y), CP, _G0, _m) :- !, + \+ ('$call'(X, CP, G0, M), + \+ '$call'(Y, CP, G0, M) ). +'$call'(once(X), CP, G0, M) :- !, + ( '$call'(X, CP, G0, M) -> true). +'$call'(!, CP, _G0, _m) :- !, + '$$cut_by'(CP). '$call'([X|Y], _, _, M) :- (Y == [] -> consult(M:X) @@ -853,7 +863,6 @@ rules: first try term_expansion/2 in the current module, and then try to use th for DCG rules is applied, together with the arithmetic optimizer whenever the compilation of arithmetic expressions is in progress. - */ expand_term(Term,Expanded) :- (