From 342faf6d89ae7786f7d70f1ccf457a7e47dcf5dd Mon Sep 17 00:00:00 2001 From: vsc Date: Thu, 3 Oct 2002 13:54:35 +0000 Subject: [PATCH] Insert Christian patches: - uncutable predicates; - call_cleanup/2. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@615 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/adtdefs.c | 2 + C/compiler.c | 129 ++++++++++++++++++++++++++------------------ C/init.c | 3 ++ library/cleanup.yap | 120 +++++++++++++++++++++++++++++++++++++++++ m4/Yatom.h.m4 | 4 +- pl/directives.yap | 10 +++- pl/errors.yap | 2 + 7 files changed, 216 insertions(+), 54 deletions(-) create mode 100644 library/cleanup.yap diff --git a/C/adtdefs.c b/C/adtdefs.c index fd77e8bba..fc2d82921 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -149,6 +149,8 @@ LookupAtom(char *atom) /* compute hash */ p = (unsigned char *)atom; HashFunction(p, hash); + if (!strcmp("in line 284, system predicate see/1 at prolog:$$compile_stat/5 (clause 1)",atom)) + fprintf(stderr,"vsc: has is %d\n", hash); WRITE_LOCK(HashChain[hash].AERWLock); a = HashChain[hash].Entry; /* search atom in chain */ diff --git a/C/compiler.c b/C/compiler.c index 4759bf03d..7c0253514 100644 --- a/C/compiler.c +++ b/C/compiler.c @@ -34,8 +34,8 @@ STATIC_PROTO(void c_arg, (Int, Term, unsigned int)); STATIC_PROTO(void c_args, (Term)); STATIC_PROTO(void c_eq, (Term, Term)); STATIC_PROTO(void c_test, (Int, Term)); -STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int)); -STATIC_PROTO(void c_goal, (Term, int)); +STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int, int *)); +STATIC_PROTO(void c_goal, (Term, int, int *)); STATIC_PROTO(void get_type_info, (Term)); STATIC_PROTO(void c_body, (Term, int)); STATIC_PROTO(void get_cl_info, (Term)); @@ -701,7 +701,7 @@ bip_cons Op,Xk,Ri,C */ static void -c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) +c_bifun(Int Op, Term t1, Term t2, Term t3, int mod, int *uncutable) { /* compile Z = X Op Y arithmetic function */ /* first we fetch the arguments */ @@ -820,7 +820,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) if (IsNumTerm(t1)) { /* we will always fail */ if (i2) - c_goal(MkAtomTerm(AtomFalse), mod); + c_goal(MkAtomTerm(AtomFalse), mod, uncutable); } else if (!IsAtomTerm(t1)) { char s[32]; @@ -891,7 +891,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) } else if (IsApplTerm(t2)) { Functor f = FunctorOfTerm(t2); if (i1 < 1 || i1 > ArityOfFunctor(f)) { - c_goal(MkAtomTerm(AtomFalse), mod); + c_goal(MkAtomTerm(AtomFalse), mod, uncutable); } else { c_eq(ArgOfTerm(i1, t2), t3); } @@ -905,7 +905,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) c_eq(TailOfTerm(t2), t3); return; default: - c_goal(MkAtomTerm(AtomFalse), mod); + c_goal(MkAtomTerm(AtomFalse), mod, uncutable); return; } } @@ -1065,13 +1065,13 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) } static void -c_functor(Term Goal, int mod) +c_functor(Term Goal, int mod, int *uncutable) { Term t1 = ArgOfTerm(1, Goal); Term t2 = ArgOfTerm(2, Goal); Term t3 = ArgOfTerm(3, Goal); if (IsVarTerm(t1) && IsNewVar(t1)) { - c_bifun(_functor, t2, t3, t1, mod); + c_bifun(_functor, t2, t3, t1, mod, uncutable); } else if (IsNonVarTerm(t1)) { /* just split the structure */ if (IsAtomicTerm(t1)) { @@ -1123,7 +1123,7 @@ IsTrueGoal(Term t) { } static void -c_goal(Term Goal, int mod) +c_goal(Term Goal, int mod, int* uncutable) { Functor f; PredEntry *p; @@ -1147,13 +1147,16 @@ c_goal(Term Goal, int mod) } if (IsNumTerm(Goal)) { FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal); - } else if (IsRefTerm(Goal)) { + } + else if (IsRefTerm(Goal)) { Error_TYPE = TYPE_ERROR_DBREF; Error_Term = Goal; FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal); - } else if (IsPairTerm(Goal)) { + } + else if (IsPairTerm(Goal)) { Goal = MkApplTerm(FunctorCall, 1, &Goal); - } else if (IsVarTerm(Goal)) { + } + else if (IsVarTerm(Goal)) { Goal = MkApplTerm(FunctorCall, 1, &Goal); } if (IsAtomTerm(Goal)) { @@ -1176,7 +1179,11 @@ c_goal(Term Goal, int mod) return; } else if (atom == AtomCut) { - + if (*uncutable){ + Error_TYPE = UNKNOWN_ERROR; /*ceh: needs an official assigned error*/ + Error_Term = Goal; + FAIL("tried to cut an uncutable goal", UNKNOWN_ERROR, Goal); + } if (profiling) emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero); else if (call_counting) @@ -1189,7 +1196,8 @@ c_goal(Term Goal, int mod) if (is_tabled(CurrentPred)) { emit(cut_op, Zero, Zero); emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE); - } else + } + else #endif /* TABLING */ { emit(cutexit_op, Zero, Zero); @@ -1235,15 +1243,16 @@ c_goal(Term Goal, int mod) emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE); else #endif /* TABLING */ - emit(procceed_op, Zero, Zero); + emit(procceed_op, Zero, Zero); #ifdef TABLING READ_UNLOCK(CurrentPred->PRWLock); #endif - } else + } + else ++goalno; onbranch = pop_branch(); emit(pop_or_op, Zero, Zero); -/* --onbranch; */ + /* --onbranch; */ return; } #endif /* YAPOR */ @@ -1277,7 +1286,7 @@ c_goal(Term Goal, int mod) do { arg = ArgOfTerm(1, Goal); looking_at_comit = IsApplTerm(arg) && - FunctorOfTerm(arg) == FunctorArrow; + FunctorOfTerm(arg) == FunctorArrow; if (frst) { if (optimizing_comit) { emit(label_op, l, Zero); @@ -1342,16 +1351,16 @@ c_goal(Term Goal, int mod) } save = onlast; onlast = FALSE; - c_goal(ArgOfTerm(1, arg), mod); + c_goal(ArgOfTerm(1, arg), mod, uncutable); if (!optimizing_comit) { c_var((Term) comitvar, comit_b_flag, 1); } onlast = save; - c_goal(ArgOfTerm(2, arg), mod); + c_goal(ArgOfTerm(2, arg), mod, uncutable); } else - c_goal(ArgOfTerm(1, Goal), mod); + c_goal(ArgOfTerm(1, Goal), mod, uncutable); if (!onlast) { emit(jump_op, m, Zero); } @@ -1368,13 +1377,13 @@ c_goal(Term Goal, int mod) else { optimizing_comit = FALSE; /* not really necessary */ } - c_goal(Goal, mod); + c_goal(Goal, mod, uncutable); /* --onbranch; */ onbranch = pop_branch(); if (!onlast) { emit(label_op, m, Zero); if ((onlast = save)) - c_goal(MkAtomTerm(AtomTrue), mod); + c_goal(MkAtomTerm(AtomTrue), mod, uncutable); } emit(pop_or_op, Zero, Zero); return; @@ -1384,9 +1393,9 @@ c_goal(Term Goal, int mod) int t2 = ArgOfTerm(2, Goal); onlast = FALSE; - c_goal(ArgOfTerm(1, Goal), mod); + c_goal(ArgOfTerm(1, Goal), mod, uncutable); onlast = save; - c_goal(t2, mod); + c_goal(t2, mod, uncutable); return; } else if (f == FunctorNot || f == FunctorAltNot) { @@ -1410,7 +1419,7 @@ c_goal(Term Goal, int mod) emit_3ops(push_or_op, label, Zero, Zero); emit_3ops(either_op, label, Zero, Zero); emit(restore_tmps_op, Zero, Zero); - c_goal(ArgOfTerm(1, Goal), mod); + c_goal(ArgOfTerm(1, Goal), mod, uncutable); c_var(comitvar, comit_b_flag, 1); onlast = save; emit(fail_op, end_label, Zero); @@ -1421,7 +1430,7 @@ c_goal(Term Goal, int mod) onlast = save; /* --onbranch; */ onbranch = pop_branch(); - c_goal(MkAtomTerm(AtomTrue), mod); + c_goal(MkAtomTerm(AtomTrue), mod, uncutable); ++goalno; emit(pop_or_op, Zero, Zero); return; @@ -1438,12 +1447,13 @@ c_goal(Term Goal, int mod) } onlast = FALSE; c_var(comitvar, save_b_flag, 1); - c_goal(ArgOfTerm(1, Goal), mod); + c_goal(ArgOfTerm(1, Goal), mod, uncutable); c_var(comitvar, comit_b_flag, 1); onlast = save; - c_goal(ArgOfTerm(2, Goal), mod); + c_goal(ArgOfTerm(2, Goal), mod, uncutable); return; - } else if (f == FunctorEq) { + } + else if (f == FunctorEq) { if (profiling) emit(enter_profiling_op, (CELL)p, Zero); else if (call_counting) @@ -1463,7 +1473,8 @@ c_goal(Term Goal, int mod) #endif } return; - } else if (p->PredFlags & AsmPredFlag) { + } + else if (p->PredFlags & AsmPredFlag) { int op = p->PredFlags & 0x7f; if (profiling) emit(enter_profiling_op, (CELL)p, Zero); @@ -1485,15 +1496,17 @@ c_goal(Term Goal, int mod) #endif } return; - } else if (op >= _plus && op <= _functor) { + } + else if (op >= _plus && op <= _functor) { if (op == _functor) { - c_functor(Goal, mod); - } else { + c_functor(Goal, mod, uncutable); + } + else { c_bifun(op, ArgOfTerm(1, Goal), ArgOfTerm(2, Goal), ArgOfTerm(3, Goal), - mod); + mod, uncutable); } if (onlast) { emit(deallocate_op, Zero, Zero); @@ -1509,10 +1522,12 @@ c_goal(Term Goal, int mod) #endif } return; - } else { + } + else { c_args(Goal); } - } else if (p->PredFlags & BinaryTestPredFlag) { + } + else if (p->PredFlags & BinaryTestPredFlag) { Term a1 = ArgOfTerm(1,Goal); if (IsVarTerm(a1) && !IsNewVar(a1)) { Term a2 = ArgOfTerm(2,Goal); @@ -1528,7 +1543,8 @@ c_goal(Term Goal, int mod) c_var(a1, bt1_flag, 2); current_p0 = p0; c_var(a2, bt2_flag, 2); - } else { + } + else { Term t2 = MkVarTerm(); if (H == (CELL *)freep0) { /* oops, too many new variables */ @@ -1541,7 +1557,8 @@ c_goal(Term Goal, int mod) current_p0 = p0; c_var(t2, bt2_flag, 2); } - } else { + } + else { Term a2 = ArgOfTerm(2,Goal); Term t1 = MkVarTerm(); if (H == (CELL *)freep0) { @@ -1549,13 +1566,14 @@ c_goal(Term Goal, int mod) save_machine_regs(); longjmp(CompilerBotch,4); } - + c_eq(t1, a1); if (IsVarTerm(a2) && !IsNewVar(a2)) { c_var(t1, bt1_flag, 2); current_p0 = p0; c_var(a2, bt2_flag, 2); - } else { + } + else { Term t2 = MkVarTerm(); if (H == (CELL *)freep0) { /* oops, too many new variables */ @@ -1579,11 +1597,12 @@ c_goal(Term Goal, int mod) #endif /* TABLING */ emit(procceed_op, Zero, Zero); #ifdef TABLING - READ_UNLOCK(CurrentPred->PRWLock); + READ_UNLOCK(CurrentPred->PRWLock); #endif } return; - } else { + } + else { if (profiling) emit(enter_profiling_op, (CELL)p, Zero); else if (call_counting) @@ -1591,12 +1610,17 @@ c_goal(Term Goal, int mod) c_args(Goal); } } + + if (p->PredFlags & UnCutAblePredFlag ){ + (void)(*uncutable)++; + } + + if (p->PredFlags & SafePredFlag #ifdef YAPOR - /* synchronisation means saving the state, so it is never safe in YAPOR */ - if (p->PredFlags & SafePredFlag && !(p->PredFlags & SyncPredFlag)) { -#else - if (p->PredFlags & SafePredFlag) { + /* synchronisation means saving the state, so it is never safe in YAPOR */ + && !(p->PredFlags & SyncPredFlag) #endif /* YAPOR */ + ) { if (onlast) emit(deallocate_op, Zero, Zero); emit(safe_call_op, (CELL) p0, Zero); @@ -1644,13 +1668,15 @@ c_goal(Term Goal, int mod) if (is_tabled(CurrentPred)) { emit_3ops(call_op, (CELL) p0, Zero, Zero); emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE); - } else + } + else #endif /* TABLING */ emit(execute_op, (CELL) p0, Zero); #ifdef TABLING READ_UNLOCK(CurrentPred->PRWLock); #endif - } else { + } + else { emit_3ops(call_op, (CELL) p0, Zero, Zero); } } @@ -1686,6 +1712,7 @@ get_type_info(Term Goal) static void c_body(Term Body, int mod) { + int uncutable=0; onhead = FALSE; BodyStart = cpc; goalno = 1; @@ -1705,11 +1732,11 @@ c_body(Term Body, int mod) Body = ArgOfTerm(1, Body); break; } - c_goal(ArgOfTerm(1, Body), mod); + c_goal(ArgOfTerm(1, Body), mod, &uncutable); Body = t2; } onlast = TRUE; - c_goal(Body, mod); + c_goal(Body, mod, &uncutable); } static void diff --git a/C/init.c b/C/init.c index 167d5d114..75ef522c4 100644 --- a/C/init.c +++ b/C/init.c @@ -396,6 +396,9 @@ static Opdef Ops[] = { #ifdef TABLING {"table", fx, 1150}, #endif /* TABLING */ +#ifndef UNCUTABLE + {"uncutable", fx, 1150}, +#endif /*UNCUTABLE ceh:*/ {";", xfy, 1100}, {"|", xfy, 1100}, /* {";", yf, 1100}, not allowed in ISO */ diff --git a/library/cleanup.yap b/library/cleanup.yap new file mode 100644 index 000000000..b7c1419ed --- /dev/null +++ b/library/cleanup.yap @@ -0,0 +1,120 @@ +:- module( cleanup, [ + call_cleanup/2, + call_cleanup/1, + on_cleanup/1, + cleanup_all/0 + ]). + +/* +public interface: + +call_cleanup(Goal). +call_cleanup(Goal,CleanUpGoal). + Goal will be called in a cleanup-context, where any registered + CleanUpGoal inside of that context will be called when Goal is left, + either by a fail, cut or exeption. + It is possible to nest cleanup contexts. + +on_cleanup(CleanUpGoal). + registers CleanUpGoal to the current cleanup context. + CleanUpGoal's are executed in reverse order of their registration. + throws an exception if called outside of any cleanup-context. + +cleanup_all. + calls all pending CleanUpGoals and resets the cleanup-system to an initial state. + should only be used as one of the last calls in the main program. + + +hidden predicates: +most private predicates could also be used in special cases, such as manually setting up cleanup-contexts. +Read the Source. +*/ + + +:- meta_predicate + call_cleanup(:,:), + call_cleanup(:), + on_cleanup(:), + on_cleanup(?,:), + on_cleanupz(:), + on_cleanupz(?,:). + + +:- initialization(init_cleanup). +init_cleanup :- + get_value('cleanup:level',[]), + set_value('cleanup:level',0). +init_cleanup. + + +% call goal G with a cleanup CL in a cleanup context +call_cleanup(G,CL) :- + needs_cleanup(L), + on_cleanup(L,CL), + ( + catch(G,X,(do_cleanup(L),throw(X))) + ; + do_cleanup(L) + ). + + +% call a goal G in a cleanup context +call_cleanup(G) :- + needs_cleanup(L), + ( + catch(G,X,(do_cleanup(L),throw(X))) + ; + do_cleanup(L) + ). + + +% begin cleanup level +needs_cleanup(CL) :- + get_value('cleanup:level',L), + CL is L + 1, + set_value('cleanup:level',CL). + + +% leave cleanup level, call all registred cleanup predicates within +do_cleanup(CL) :- + CN is CL - 1, + set_value('cleanup:level',CN), + next_cleanup(CL). + +next_cleanup(CL) :- + !,recorded(cleanup:handle,(L,G),R), + CL =< L, + erase(R), + (call(G);true), + next_cleanup(CL). + + +% clean up all remaining stuff / reinitialize cleanup-module +cleanup_all :- do_cleanup(1). + + +% register a cleanup predicate (normal reverse-order cleanup) +on_cleanup(G) :- + get_value('cleanup:level',L), + on_cleanup(L,G). + +on_cleanup(L,G) :- + L =< 0, + throw(no_cleanup_context(G)). +on_cleanup(L,G) :- + callable(G), + recorda(cleanup:handle,(L,G),_). + + +% register a cleanup predicate (reverse-reverse-order cleanup) +on_cleanupz(G) :- + get_value('cleanup:level',L), + on_cleanupz(L,G). + +on_cleanupz(L,G) :- + L =< 0, + throw(no_cleanup_context(G)). +on_cleanupz(L,G) :- + callable(G), + recordz(cleanup:handle,(L,G),_). + diff --git a/m4/Yatom.h.m4 b/m4/Yatom.h.m4 index b0153580d..91753d524 100644 --- a/m4/Yatom.h.m4 +++ b/m4/Yatom.h.m4 @@ -189,7 +189,9 @@ typedef enum { SequentialPredFlag=0x000020L, /* may not create par. choice points!*/ #endif /* YAPOR */ ProfiledPredFlag = 0x000010L, /* pred is being profiled */ - LogUpdatePredFlag= 0x000008L /* dynamic predicate with log. upd. sem.*/ + LogUpdatePredFlag= 0x000008L, /* dynamic predicate with log. upd. sem.*/ + /* ceh: wtf! 0x000004L is used somewhere? */ + UnCutAblePredFlag= 0x000002L /* Predicate might no been cut off */ } pred_flag; /* profile data */ diff --git a/pl/directives.yap b/pl/directives.yap index 631603d20..ecc089b52 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -39,6 +39,7 @@ '$directive'(use_module(_)). '$directive'(use_module(_,_)). '$directive'(use_module(_,_,_)). +'$directive'(uncutable(_)). '$exec_directive'(multifile(D), _, M) :- '$system_catch'('$multifile'(D, M), M, @@ -94,6 +95,9 @@ '$wait'(BlockSpec). '$exec_directive'(table(PredSpec), _, M) :- '$table'(PredSpec, M). +'$exec_directive'(uncutable(PredSpec), _, M) :- + '$uncutable'(PredSpec, M). + '$exec_directives'((G1,G2), Mode, M) :- !, '$exec_directives'(G1, Mode, M), @@ -101,8 +105,10 @@ '$exec_directives'(G, Mode, M) :- '$exec_directive'(G, Mode, M). - - +'$uncutable'(A/N, Mod) :- + functor(T,A,N),'$flags'(T,Mod,F,F), + NF is F \/ 16'2, + '$flags'(T, Mod, F, NF). yap_flag(V,Out) :- var(V), !, diff --git a/pl/errors.yap b/pl/errors.yap index 664a3d6d6..e2dd1a4d4 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -165,6 +165,8 @@ print_message(Level, Mss) :- '$preprocess_stack'(Gs, NGs). '$beautify_hidden_goal'('$recordedp',_,prolog,ClNo,Gs,NGs) :- !, '$preprocess_stack'(Gs, NGs). +'$beautify_hidden_goal'('$continue_with_command',_,prolog,ClNo,Gs,NGs) :- !, + '$preprocess_stack'(Gs, NGs). '$beautify_hidden_goal'('$system_catch',_,prolog,ClNo,Gs,NGs) :- !, '$preprocess_stack'(Gs, NGs). '$beautify_hidden_goal'('$execute_command',_,prolog,ClNo,Gs,NGs) :- !,