From 00886e5205c5d8e6da82807b3cbc2803833daf5e Mon Sep 17 00:00:00 2001 From: vsc Date: Tue, 10 Dec 2002 14:36:22 +0000 Subject: [PATCH] key_statistics/3 disable stack dump by default: yap_flags(stack_dump,_). git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@720 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/cdmgr.c | 127 +++++++++++----------------------------------- C/dbase.c | 23 +++++++++ C/stdpreds.c | 5 ++ docs/yap.tex | 23 +++++++-- m4/Yap.h.m4 | 7 +-- pl/directives.yap | 14 +++++ 6 files changed, 96 insertions(+), 103 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index a62e90804..0b1d13cc7 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -79,7 +79,6 @@ STATIC_PROTO(Int p_call_count_info, (void)); STATIC_PROTO(Int p_call_count_set, (void)); STATIC_PROTO(Int p_call_count_reset, (void)); STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void)); -STATIC_PROTO(void list_all_predicates_in_use, (void)); STATIC_PROTO(Atom YapConsultingFile, (void)); STATIC_PROTO(Int PredForCode,(CODEADDR, Atom *, UInt *, SMALLUNSGN *)); @@ -1919,90 +1918,6 @@ search_for_static_predicate_in_use(PredEntry *p, int check_everything) return(FALSE); } -#ifdef DEBUG -#ifndef ANALYST - -static char *op_names[_std_top + 1] = -{ -#define OPCODE(OP,TYPE) #OP -#include "YapOpcodes.h" -#undef OPCODE -}; - -#endif - -static void -list_all_predicates_in_use(void) -{ - choiceptr b_ptr = B; - CELL *env_ptr = ENV; - - do { - /* - I do not need to check environments for asserts, - only for retracts - */ - while (b_ptr > (choiceptr)env_ptr) { - PredEntry *pe = EnvPreg(env_ptr[E_CP]); - op_numbers op = Yap_op_from_opcode(ENV_ToOp(env_ptr[E_CP])); - if (pe->ArityOfPE) - fprintf(Yap_stderr," ENV %p %s/%d %s\n", env_ptr, RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, op_names[op]); - else - fprintf(Yap_stderr," ENV %p %s %s\n", env_ptr, RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, op_names[op]); - env_ptr = (CELL *)(env_ptr[E_E]); - } - restart_cp: - /* now mark the choicepoint */ - if (b_ptr != NULL) { - op_numbers opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc); - - switch (opnum) { - case _or_else: - case _or_last: - case _Nstop: - case _switch_last: - case _switch_l_list: - case _retry_c: - case _retry_userc: - case _trust_logical_pred: - case _retry_profiled: - case _count_retry: - { - Atom at; - UInt arity; - SMALLUNSGN mod; - if (PredForCode((CODEADDR)b_ptr->cp_ap, &at, &arity, &mod)) { - if (arity) - fprintf(Yap_stderr,"CP %p %s/%d (%s)\n", b_ptr, RepAtom(at)->StrOfAE, arity, op_names[opnum]); - else - fprintf(Yap_stderr,"CP %p %s (%s)\n", b_ptr, RepAtom(at)->StrOfAE, op_names[opnum]); - } else - fprintf(Yap_stderr,"CP %p (%s)\n", b_ptr, op_names[opnum]); - } - break; - default: - { - PredEntry *pe = (PredEntry *)b_ptr->cp_ap->u.ld.p; - if (pe == NULL) { - fprintf(Yap_stderr,"CP %p (%s)\n", b_ptr, op_names[opnum]); - } else - if (pe->ArityOfPE) - fprintf(Yap_stderr,"CP %p %s/%d (%s)\n", b_ptr, RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, op_names[opnum]); - else - fprintf(Yap_stderr,"CP %p %s (%s)\n", b_ptr, RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, op_names[opnum]); - } - } - if (opnum == _retry_profiled || opnum == _count_retry) { - opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc); - goto restart_cp; - } - } - env_ptr = b_ptr->cp_env; - b_ptr = b_ptr->cp_b; - } while (b_ptr != NULL); -} -#endif - static void mark_pred(int mark, PredEntry *pe) { @@ -2079,16 +1994,11 @@ do_toggle_static_predicates_in_use(int mask) #endif static Term -all_calls(void) +all_envs(CELL *env_ptr) { - choiceptr b_ptr = B; - CELL *env_ptr = ENV; + Term tf = AbsPair(H); CELL *bp = NULL; - Term ts[3]; - Functor f = Yap_MkFunctor(AtomLocal,3); - - ts[0] = MkIntegerTerm((Int)P); - ts[1] = AbsPair(H); + /* walk the environment chain */ while (env_ptr != NULL) { bp = H; @@ -2097,14 +2007,22 @@ all_calls(void) bp[0] = MkIntegerTerm((Int)env_ptr[E_CP]); if (H >= ASP) { bp[1] = TermNil; - return(ts[0]); + return tf; } else { bp[1] = AbsPair(H); } env_ptr = (CELL *)(env_ptr[E_E]); } bp[1] = TermNil; - ts[2] = AbsPair(H); + return tf; +} + +static Term +all_cps(choiceptr b_ptr) +{ + CELL *bp = NULL; + Term tf = AbsPair(H); + while (b_ptr != NULL) { bp = H; H += 2; @@ -2112,13 +2030,30 @@ all_calls(void) bp[0] = MkIntegerTerm((Int)b_ptr->cp_ap); if (H >= ASP) { bp[1] = TermNil; - return(ts[0]); + return tf; } else { bp[1] = AbsPair(H); } b_ptr = b_ptr->cp_b; } bp[1] = TermNil; + return tf; +} + + +static Term +all_calls(void) +{ + Term ts[3]; + Functor f = Yap_MkFunctor(AtomLocal,3); + + ts[0] = MkIntegerTerm((Int)P); + if (yap_flags[STACK_DUMP_ON_ERROR_FLAG]) { + ts[1] = all_envs(ENV); + ts[1] = all_cps(B); + } else { + ts[1] = ts[2] = TermNil; + } return(Yap_MkApplTerm(f,3,ts)); } diff --git a/C/dbase.c b/C/dbase.c index 6bbb13ef6..9ae612567 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -3125,6 +3125,28 @@ p_first_instance(void) return(Yap_unify(ARG3, TRef)); } +static Int +p_key_statistics(void) +{ + Register DBProp p; + Register DBRef x; + UInt sz = 0, cls = 0; + if (EndOfPAEntr(p = FetchDBPropFromKey(Deref(ARG1), 0, TRUE, "key_statistics/3"))) { + /* This is not a key property */ + return(FALSE); + } + /* count number of clauses and size */ + x = p->First; + while (x != NULL) { + cls++; + sz += Yap_SizeOfBlock((CODEADDR)x); + x = NextDBRef(x); + } + return(Yap_unify(ARG2,MkIntegerTerm(cls)) && + Yap_unify(ARG3,MkIntegerTerm(sz))); +} + + /* * This is called when we are erasing a data base clause, because we may have * pending references @@ -4463,6 +4485,7 @@ Yap_InitDBPreds(void) Yap_InitCPred("$hold_index", 3, p_hold_index, SafePredFlag|SyncPredFlag); Yap_InitCPred("$fetch_reference_from_index", 3, p_fetch_reference_from_index, SafePredFlag|SyncPredFlag); Yap_InitCPred("$resize_int_keys", 1, p_resize_int_keys, SafePredFlag|SyncPredFlag); + Yap_InitCPred("key_statistics", 3, p_key_statistics, SyncPredFlag); } void diff --git a/C/stdpreds.c b/C/stdpreds.c index d59bfaab5..5e62fcc04 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -2195,6 +2195,11 @@ p_set_yap_flags(void) return(FALSE); yap_flags[ALLOW_ASSERTING_STATIC_FLAG] = value; break; + case STACK_DUMP_ON_ERROR_FLAG: + if (value != 0 && value != 1) + return(FALSE); + yap_flags[STACK_DUMP_ON_ERROR_FLAG] = value; + break; default: return(FALSE); } diff --git a/docs/yap.tex b/docs/yap.tex index 67c187656..cc1d2b2e1 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -4957,7 +4957,7 @@ If a term equal to @var{T} up to variable renaming is stored under key @item recordzifnot(+@var{K},@var{T},-@var{R}) @findex recorda/3 -@saindex recorda/3 +@snindex recorda/3 @cnindex recorda/3 If a term equal to @var{T} up to variable renaming is stored under key @var{K} fail. Otherwise, make term @var{T} the first record under key @@ -5008,12 +5008,21 @@ this goal fails. All terms belonging to the key @code{K} are erased from the internal database. The predicate always succeeds. -@item current_key(@var{A},@var{P}) +@item current_key(?@var{A},?@var{K}) @findex current_key/2 @syindex current_key/2 @cnindex current_key/2 -Defines the relation: @var{P} is a currently defined database key whose -name is the atom @var{A}. +Defines the relation: @var{K} is a currently defined database key whose +name is the atom @var{A}. It can be used to generate all the keys for +the internal data-base. + +@item key_statistics(+@var{K},-@var{Entries},-@var{Size}) +@findex key_properties/3 +@snindex key_properties/3 +@cnindex key_properties/3 +Returns several statistics for a key @var{K}. Currently, it says how +many entries we have for that key, @var{Entries}, and what is the +total size spent on the key, @var{Size}. @item get_value(+@var{A},-@var{V}) @findex get_value/2 @@ -6356,6 +6365,12 @@ will work the same way in every Prolog and in every platform. We thus believe this mode is mostly useful when investigating how a program depends on a Prolog's platform specific features. +@item stack_dump_on_error +@findex stack_dump_on_error (yap_flag/2 option) +@* +If @code{on} show a stack dump when Yap finds an error. The default is +@code{off}. + @item syntax_errors @findex syntax_errors (yap_flag/2 option) @* diff --git a/m4/Yap.h.m4 b/m4/Yap.h.m4 index fd7d08cea..c561ccb86 100644 --- a/m4/Yap.h.m4 +++ b/m4/Yap.h.m4 @@ -10,7 +10,7 @@ * File: Yap.h.m4 * * mods: * * comments: main header file for YAP * -* version: $Id: Yap.h.m4,v 1.39 2002-11-26 22:28:32 vsc Exp $ * +* version: $Id: Yap.h.m4,v 1.40 2002-12-10 14:36:21 vsc Exp $ * *************************************************************************/ #include "config.h" @@ -508,7 +508,8 @@ typedef enum { WRITE_QUOTED_STRING_FLAG = 13, ALLOW_ASSERTING_STATIC_FLAG = 14, HALT_AFTER_CONSULT_FLAG = 15, - FAST_BOOT_FLAG = 16 + FAST_BOOT_FLAG = 16, + STACK_DUMP_ON_ERROR_FLAG = 17 } yap_flags; #define STRING_AS_CHARS 0 @@ -521,7 +522,7 @@ typedef enum { #define ISO_CHARACTER_ESCAPES 1 #define SICSTUS_CHARACTER_ESCAPES 2 -#define NUMBER_OF_YAP_FLAGS FAST_BOOT_FLAG+1 +#define NUMBER_OF_YAP_FLAGS STACK_DUMP_ON_ERROR_FLAG+1 /************************ prototypes **********************************/ diff --git a/pl/directives.yap b/pl/directives.yap index ecc089b52..a75a7788d 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -452,6 +452,19 @@ yap_flag(write_strings,off) :- !, yap_flag(write_strings,X) :- '$do_error'(domain_error(flag_value,write_strings+X),yap_flag(write_strings,X)). +yap_flag(stack_dump_on_error,OUT) :- + var(OUT), !, + '$access_yap_flags'(17,X), + '$transl_to_on_off'(X,OUT). +yap_flag(stack_dump_on_error,on) :- !, + '$transl_to_on_off'(X,on), + '$set_yap_flags'(17,X). +yap_flag(stack_dump_on_error,off) :- !, + '$transl_to_on_off'(X,off), + '$set_yap_flags'(17,X). +yap_flag(stack_dump_on_error,X) :- + '$do_error'(domain_error(flag_value,stack_dump_on_error+X),yap_flag(stack_dump_on_error,X)). + yap_flag(user_input,OUT) :- var(OUT), !, '$flag_check_alias'(OUT, user_input). @@ -535,6 +548,7 @@ yap_flag(host_type,X) :- V = redefine_warnings ; V = single_var_warnings ; V = strict_iso ; + V = stack_dump_on_error ; V = syntax_errors ; V = to_chars_mode ; V = toplevel_hook ;