libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #ifdef HAVE_GETRLIMIT
  26 #include <sys/time.h>
  27 #include <sys/resource.h>
  28 #endif
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/async.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/list.h"
  34 #include "libguile/stackchk.h"
  35 #include "libguile/throw.h"
  36 #include "libguile/macros.h"
  37 #include "libguile/smob.h"
  38 #include "libguile/struct.h"
  39 #include "libguile/procprop.h"
  40 #include "libguile/srcprop.h"
  41 #include "libguile/alist.h"
  42 #include "libguile/continuations.h"
  43 #include "libguile/strports.h"
  44 #include "libguile/read.h"
  45 #include "libguile/feature.h"
  46 #include "libguile/dynwind.h"
  47 #include "libguile/modules.h"
  48 #include "libguile/ports.h"
  49 #include "libguile/root.h"
  50 #include "libguile/fluids.h"
  51 #include "libguile/programs.h"
  52 #include "libguile/memoize.h"
  53 #include "libguile/vm.h"
  54
  55 #include "libguile/validate.h"
  56 #include "libguile/debug.h"
  57
  58 #include "libguile/private-options.h"
  59 \f
  60
  61
  62 /*
  63  * Debugging options.
  64  */
  65
  66 scm_t_option scm_debug_opts[] = {
  67   { SCM_OPTION_BOOLEAN, "backwards", 0,
  68     "Display backtrace in anti-chronological order." },
  69   { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
  70   { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
  71   { SCM_OPTION_BOOLEAN, "backtrace", 1, "Show backtrace on error." },
  72   /* This default stack limit will be overridden by init_stack_limit(),
  73      if we have getrlimit() and the stack limit is not INFINITY. But it is still
  74      important, as some systems have both the soft and the hard limits set to
  75      INFINITY; in that case we fall back to this value.
  76
  77      The situation is aggravated by certain compilers, which can consume
  78      "beaucoup de stack", as they say in France.
  79
  80      See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
  81      more discussion. This setting is 640 KB on 32-bit arches (should be enough
  82      for anyone!) or a whoppin' 1280 KB on 64-bit arches.
  83   */
  84   { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
  85   { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS,
  86     "Show file names and line numbers "
  87     "in backtraces when not `#f'.  A value of `base' "
  88     "displays only base names, while `#t' displays full names."},
  89   { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
  90     "Warn when deprecated features are used." },
  91   { 0 },
  92 };
  93
  94
  95 /* {Run time control of the debugging evaluator}
  96  */
  97
  98 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  99             (SCM setting),
 100             "Option interface for the debug options. Instead of using\n"
 101             "this procedure directly, use the procedures @code{debug-enable},\n"
 102             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
 103 #define FUNC_NAME s_scm_debug_options
 104 {
 105   SCM ans;
 106
 107   scm_dynwind_begin (0);
 108   scm_dynwind_critical_section (SCM_BOOL_F);
 109
 110   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
 111 #ifdef STACK_CHECKING
 112   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 113 #endif
 114
 115   scm_dynwind_end ();
 116   return ans;
 117 }
 118 #undef FUNC_NAME
 119
 120 \f
 121 SCM_SYMBOL (scm_sym_source, "source");
 122
 123 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 124             (SCM proc),
 125             "Return the name of the procedure @var{proc}")
 126 #define FUNC_NAME s_scm_procedure_name
 127 {
 128   SCM_VALIDATE_PROC (1, proc);
 129   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 130     proc = SCM_STRUCT_PROCEDURE (proc);
 131   return scm_procedure_property (proc, scm_sym_name);
 132 }
 133 #undef FUNC_NAME
 134
 135 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 136             (SCM proc),
 137             "Return the source of the procedure @var{proc}.")
 138 #define FUNC_NAME s_scm_procedure_source
 139 {
 140   SCM src;
 141   SCM_VALIDATE_PROC (1, proc);
 142
 143   do
 144     {
 145       src = scm_procedure_property (proc, scm_sym_source);
 146       if (scm_is_true (src))
 147         return src;
 148
 149       switch (SCM_TYP7 (proc)) {
 150       case scm_tcs_struct:
 151         if (!SCM_STRUCT_APPLICABLE_P (proc)
 152             || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
 153           break;
 154         proc = SCM_STRUCT_PROCEDURE (proc);
 155         continue;
 156       default:
 157         break;
 158       }
 159     }
 160   while (0);
 161
 162   return SCM_BOOL_F;
 163 }
 164 #undef FUNC_NAME
 165
 166
 167 \f
 168
 169 #if 0
 170 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 171 #endif
 172
 173 SCM
 174 scm_reverse_lookup (SCM env, SCM data)
 175 {
 176   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 177     {
 178       SCM names = SCM_CAAR (env);
 179       SCM values = SCM_CDAR (env);
 180       while (scm_is_pair (names))
 181         {
 182           if (scm_is_eq (SCM_CAR (values), data))
 183             return SCM_CAR (names);
 184           names = SCM_CDR (names);
 185           values = SCM_CDR (values);
 186         }
 187       if (!scm_is_null (names) && scm_is_eq (values, data))
 188         return names;
 189       env = SCM_CDR (env);
 190     }
 191   return SCM_BOOL_F;
 192 }
 193
 194 \f
 195
 196 /* Undocumented debugging procedure */
 197 #ifdef GUILE_DEBUG
 198 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 199             (SCM obj),
 200             "Go into an endless loop, which can be only terminated with\n"
 201             "a debugger.")
 202 #define FUNC_NAME s_scm_debug_hang
 203 {
 204   int go = 0;
 205   while (!go) ;
 206   return SCM_UNSPECIFIED;
 207 }
 208 #undef FUNC_NAME
 209 #endif
 210
 211 static SCM local_eval_var;
 212
 213 static void
 214 init_local_eval_var (void)
 215 {
 216   local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
 217 }
 218
 219 SCM
 220 scm_local_eval (SCM exp, SCM env)
 221 {
 222   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 223   scm_i_pthread_once (&once, init_local_eval_var);
 224
 225   return scm_call_2 (scm_variable_ref (local_eval_var), exp, env);
 226 }
 227
 228 static void
 229 init_stack_limit (void)
 230 {
 231 #ifdef HAVE_GETRLIMIT
 232   struct rlimit lim;
 233   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 234       {
 235         rlim_t bytes = lim.rlim_cur;
 236
 237         /* set our internal stack limit to 80% of the rlimit. */
 238         if (bytes == RLIM_INFINITY)
 239           bytes = lim.rlim_max;
 240
 241         if (bytes != RLIM_INFINITY)
 242           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 243       }
 244   errno = 0;
 245 #endif
 246 }
 247
 248 \f
 249
 250 void
 251 scm_init_debug ()
 252 {
 253   init_stack_limit ();
 254   scm_init_opts (scm_debug_options, scm_debug_opts);
 255
 256   scm_add_feature ("debug-extensions");
 257
 258 #include "libguile/debug.x"
 259 }
 260
 261 /*
 262   Local Variables:
 263   c-file-style: "gnu"
 264   End:
 265 */