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, 2013 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 #ifdef __MINGW32__
  31 # define WIN32_LEAN_AND_MEAN
  32 # include <windows.h>
  33 #endif
  34
  35 #include "libguile/_scm.h"
  36 #include "libguile/async.h"
  37 #include "libguile/eval.h"
  38 #include "libguile/list.h"
  39 #include "libguile/stackchk.h"
  40 #include "libguile/throw.h"
  41 #include "libguile/macros.h"
  42 #include "libguile/smob.h"
  43 #include "libguile/struct.h"
  44 #include "libguile/procprop.h"
  45 #include "libguile/srcprop.h"
  46 #include "libguile/alist.h"
  47 #include "libguile/continuations.h"
  48 #include "libguile/strports.h"
  49 #include "libguile/read.h"
  50 #include "libguile/feature.h"
  51 #include "libguile/dynwind.h"
  52 #include "libguile/modules.h"
  53 #include "libguile/ports.h"
  54 #include "libguile/root.h"
  55 #include "libguile/fluids.h"
  56 #include "libguile/programs.h"
  57 #include "libguile/memoize.h"
  58 #include "libguile/vm.h"
  59
  60 #include "libguile/validate.h"
  61 #include "libguile/debug.h"
  62
  63 #include "libguile/private-options.h"
  64 \f
  65
  66
  67 /*
  68  * Debugging options.
  69  */
  70
  71 scm_t_option scm_debug_opts[] = {
  72   { SCM_OPTION_BOOLEAN, "backwards", 0,
  73     "Display backtrace in anti-chronological order." },
  74   { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
  75   { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
  76   { SCM_OPTION_BOOLEAN, "backtrace", 1, "Show backtrace on error." },
  77   /* This default stack limit will be overridden by init_stack_limit(),
  78      if we have getrlimit() and the stack limit is not INFINITY. But it is still
  79      important, as some systems have both the soft and the hard limits set to
  80      INFINITY; in that case we fall back to this value.
  81
  82      The situation is aggravated by certain compilers, which can consume
  83      "beaucoup de stack", as they say in France.
  84
  85      See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
  86      more discussion. This setting is 640 KB on 32-bit arches (should be enough
  87      for anyone!) or a whoppin' 1280 KB on 64-bit arches.
  88   */
  89   { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
  90   { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T_BITS,
  91     "Show file names and line numbers "
  92     "in backtraces when not `#f'.  A value of `base' "
  93     "displays only base names, while `#t' displays full names."},
  94   { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
  95     "Warn when deprecated features are used." },
  96   { 0 },
  97 };
  98
  99
 100 /* {Run time control of the debugging evaluator}
 101  */
 102
 103 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
 104             (SCM setting),
 105             "Option interface for the debug options. Instead of using\n"
 106             "this procedure directly, use the procedures @code{debug-enable},\n"
 107             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
 108 #define FUNC_NAME s_scm_debug_options
 109 {
 110   SCM ans;
 111
 112   scm_dynwind_begin (0);
 113   scm_dynwind_critical_section (SCM_BOOL_F);
 114
 115   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
 116   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 117
 118   scm_dynwind_end ();
 119   return ans;
 120 }
 121 #undef FUNC_NAME
 122
 123
 124 \f
 125
 126 #if 0
 127 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 128 #endif
 129
 130 SCM
 131 scm_reverse_lookup (SCM env, SCM data)
 132 {
 133   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 134     {
 135       SCM names = SCM_CAAR (env);
 136       SCM values = SCM_CDAR (env);
 137       while (scm_is_pair (names))
 138         {
 139           if (scm_is_eq (SCM_CAR (values), data))
 140             return SCM_CAR (names);
 141           names = SCM_CDR (names);
 142           values = SCM_CDR (values);
 143         }
 144       if (!scm_is_null (names) && scm_is_eq (values, data))
 145         return names;
 146       env = SCM_CDR (env);
 147     }
 148   return SCM_BOOL_F;
 149 }
 150
 151 \f
 152
 153 /* Undocumented debugging procedure */
 154 #ifdef GUILE_DEBUG
 155 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 156             (SCM obj),
 157             "Go into an endless loop, which can be only terminated with\n"
 158             "a debugger.")
 159 #define FUNC_NAME s_scm_debug_hang
 160 {
 161   int go = 0;
 162   while (!go) ;
 163   return SCM_UNSPECIFIED;
 164 }
 165 #undef FUNC_NAME
 166 #endif
 167
 168 static SCM local_eval_var;
 169
 170 static void
 171 init_local_eval_var (void)
 172 {
 173   local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
 174 }
 175
 176 SCM
 177 scm_local_eval (SCM exp, SCM env)
 178 {
 179   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 180   scm_i_pthread_once (&once, init_local_eval_var);
 181
 182   return scm_call_2 (scm_variable_ref (local_eval_var), exp, env);
 183 }
 184
 185 static void
 186 init_stack_limit (void)
 187 {
 188 #if defined HAVE_GETRLIMIT
 189   struct rlimit lim;
 190   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 191       {
 192         rlim_t bytes = lim.rlim_cur;
 193
 194         /* set our internal stack limit to 80% of the rlimit. */
 195         if (bytes == RLIM_INFINITY)
 196           bytes = lim.rlim_max;
 197
 198         if (bytes != RLIM_INFINITY)
 199           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 200       }
 201   errno = 0;
 202 #elif defined __MINGW32__
 203   MEMORY_BASIC_INFORMATION m;
 204   uintptr_t bytes;
 205
 206   if (VirtualQuery ((LPCVOID) &m, &m, sizeof m))
 207     {
 208       bytes = (DWORD_PTR) m.BaseAddress + m.RegionSize
 209                - (DWORD_PTR) m.AllocationBase;
 210       SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 211     }
 212 #endif
 213 }
 214
 215 \f
 216
 217 void
 218 scm_init_debug ()
 219 {
 220   init_stack_limit ();
 221   scm_init_opts (scm_debug_options, scm_debug_opts);
 222
 223   scm_add_feature ("debug-extensions");
 224
 225 #include "libguile/debug.x"
 226 }
 227
 228 /*
 229   Local Variables:
 230   c-file-style: "gnu"
 231   End:
 232 */