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

@@ -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;
+  Term tf = AbsPair(H);
-  CELL *env_ptr = ENV;
   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));
 }
 

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 

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);
   }

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
+Defines the relation: @var{K} is a currently defined database key whose
-name is the atom @var{A}.
+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)
 @*

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 **********************************/
 

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 ;