libguile/debug.c

   1 /* Debugging extensions for Guile
   2  * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 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/procprop.h"
  39 #include "libguile/srcprop.h"
  40 #include "libguile/alist.h"
  41 #include "libguile/continuations.h"
  42 #include "libguile/strports.h"
  43 #include "libguile/read.h"
  44 #include "libguile/feature.h"
  45 #include "libguile/dynwind.h"
  46 #include "libguile/modules.h"
  47 #include "libguile/ports.h"
  48 #include "libguile/root.h"
  49 #include "libguile/fluids.h"
  50 #include "libguile/objects.h"
  51 #include "libguile/programs.h"
  52
  53 #include "libguile/validate.h"
  54 #include "libguile/debug.h"
  55
  56 #include "libguile/private-options.h"
  57 \f
  58
  59
  60 /* {Run time control of the debugging evaluator}
  61  */
  62
  63 SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
  64             (SCM setting),
  65             "Option interface for the debug options. Instead of using\n"
  66             "this procedure directly, use the procedures @code{debug-enable},\n"
  67             "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
  68 #define FUNC_NAME s_scm_debug_options
  69 {
  70   SCM ans;
  71
  72   scm_dynwind_begin (0);
  73   scm_dynwind_critical_section (SCM_BOOL_F);
  74
  75   ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
  76   if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
  77     {
  78       scm_options (ans, scm_debug_opts, FUNC_NAME);
  79       SCM_OUT_OF_RANGE (1, setting);
  80     }
  81   SCM_RESET_DEBUG_MODE;
  82 #ifdef STACK_CHECKING
  83   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
  84 #endif
  85   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
  86
  87   scm_dynwind_end ();
  88   return ans;
  89 }
  90 #undef FUNC_NAME
  91
  92
  93 static void
  94 with_traps_before (void *data)
  95 {
  96   int *trap_flag = data;
  97   *trap_flag = SCM_TRAPS_P;
  98   SCM_TRAPS_P = 1;
  99 }
 100
 101 static void
 102 with_traps_after (void *data)
 103 {
 104   int *trap_flag = data;
 105   SCM_TRAPS_P = *trap_flag;
 106 }
 107
 108 static SCM
 109 with_traps_inner (void *data)
 110 {
 111   SCM thunk = SCM_PACK ((scm_t_bits) data);
 112   return scm_call_0 (thunk);
 113 }
 114
 115 SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
 116             (SCM thunk),
 117             "Call @var{thunk} with traps enabled.")
 118 #define FUNC_NAME s_scm_with_traps
 119 {
 120   int trap_flag;
 121   SCM_VALIDATE_THUNK (1, thunk);
 122   return scm_internal_dynamic_wind (with_traps_before,
 123                                     with_traps_inner,
 124                                     with_traps_after,
 125                                     (void *) SCM_UNPACK (thunk),
 126                                     &trap_flag);
 127 }
 128 #undef FUNC_NAME
 129
 130 \f
 131 SCM_SYMBOL (scm_sym_procname, "procname");
 132 SCM_SYMBOL (scm_sym_dots, "...");
 133 SCM_SYMBOL (scm_sym_source, "source");
 134
 135 /* {Memoized Source}
 136  */
 137
 138 scm_t_bits scm_tc16_memoized;
 139
 140 static int
 141 memoized_print (SCM obj, SCM port, scm_print_state *pstate)
 142 {
 143   int writingp = SCM_WRITINGP (pstate);
 144   scm_puts ("#<memoized ", port);
 145   SCM_SET_WRITINGP (pstate, 1);
 146   scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
 147   SCM_SET_WRITINGP (pstate, writingp);
 148   scm_putc ('>', port);
 149   return 1;
 150 }
 151
 152 SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
 153             (SCM obj),
 154             "Return @code{#t} if @var{obj} is memoized.")
 155 #define FUNC_NAME s_scm_memoized_p
 156 {
 157   return scm_from_bool(SCM_MEMOIZEDP (obj));
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM
 162 scm_make_memoized (SCM exp, SCM env)
 163 {
 164   /* *fixme* Check that env is a valid environment. */
 165   SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
 166 }
 167
 168 #ifdef GUILE_DEBUG
 169 /*
 170  * Some primitives for construction of memoized code
 171  *
 172  * - procedure: memcons CAR CDR [ENV]
 173  *
 174  *     Construct a pair, encapsulated in a memoized object.
 175  *
 176  *     The CAR and CDR can be either normal or memoized.  If ENV isn't
 177  *     specified, the top-level environment of the current module will
 178  *     be assumed.  All environments must match.
 179  *
 180  * - procedure: make-iloc FRAME BINDING CDRP
 181  *
 182  *     Return an iloc referring to frame no. FRAME, binding
 183  *     no. BINDING.  If CDRP is non-#f, the iloc is referring to a
 184  *     frame consisting of a single pair, with the value stored in the
 185  *     CDR.
 186  *
 187  * - procedure: iloc? OBJECT
 188  *
 189  *     Return #t if OBJECT is an iloc.
 190  *
 191  * - procedure: mem->proc MEMOIZED
 192  *
 193  *     Construct a closure from the memoized lambda expression MEMOIZED
 194  *
 195  *     WARNING! The code is not copied!
 196  *
 197  * - procedure: proc->mem CLOSURE
 198  *
 199  *     Turn the closure CLOSURE into a memoized object.
 200  *
 201  *     WARNING! The code is not copied!
 202  *
 203  * - constant: SCM_IM_AND
 204  * - constant: SCM_IM_BEGIN
 205  * - constant: SCM_IM_CASE
 206  * - constant: SCM_IM_COND
 207  * - constant: SCM_IM_DO
 208  * - constant: SCM_IM_IF
 209  * - constant: SCM_IM_LAMBDA
 210  * - constant: SCM_IM_LET
 211  * - constant: SCM_IM_LETSTAR
 212  * - constant: SCM_IM_LETREC
 213  * - constant: SCM_IM_OR
 214  * - constant: SCM_IM_QUOTE
 215  * - constant: SCM_IM_SET
 216  * - constant: SCM_IM_DEFINE
 217  * - constant: SCM_IM_APPLY
 218  * - constant: SCM_IM_CONT
 219  * - constant: SCM_IM_DISPATCH
 220  */
 221
 222 #include "libguile/variable.h"
 223 #include "libguile/procs.h"
 224
 225 SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
 226             (SCM car, SCM cdr, SCM env),
 227             "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
 228             "as members and @var{env} as the environment.")
 229 #define FUNC_NAME s_scm_memcons
 230 {
 231   if (SCM_MEMOIZEDP (car))
 232     {
 233       /*fixme* environments may be two different but equal top-level envs */
 234       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
 235         SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
 236                         scm_list_2 (car, env));
 237       else
 238         env = SCM_MEMOIZED_ENV (car);
 239       car = SCM_MEMOIZED_EXP (car);
 240     }
 241   if (SCM_MEMOIZEDP (cdr))
 242     {
 243       if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
 244         SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
 245                         scm_list_2 (cdr, env));
 246       else
 247         env = SCM_MEMOIZED_ENV (cdr);
 248       cdr = SCM_MEMOIZED_EXP (cdr);
 249     }
 250   if (SCM_UNBNDP (env))
 251     env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 252   else
 253     SCM_VALIDATE_NULLORCONS (3, env);
 254   return scm_make_memoized (scm_cons (car, cdr), env);
 255 }
 256 #undef FUNC_NAME
 257
 258 SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
 259             (SCM obj),
 260             "Convert a memoized object (which must represent a body)\n"
 261             "to a procedure.")
 262 #define FUNC_NAME s_scm_mem_to_proc
 263 {
 264   SCM env;
 265   SCM_VALIDATE_MEMOIZED (1, obj);
 266   env = SCM_MEMOIZED_ENV (obj);
 267   obj = SCM_MEMOIZED_EXP (obj);
 268   return scm_closure (obj, env);
 269 }
 270 #undef FUNC_NAME
 271
 272 SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
 273             (SCM obj),
 274             "Convert a procedure to a memoized object.")
 275 #define FUNC_NAME s_scm_proc_to_mem
 276 {
 277   SCM_VALIDATE_CLOSURE (1, obj);
 278   return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
 279 }
 280 #undef FUNC_NAME
 281
 282 #endif /* GUILE_DEBUG */
 283
 284 SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
 285             (SCM m),
 286             "Unmemoize the memoized expression @var{m},")
 287 #define FUNC_NAME s_scm_i_unmemoize_expr
 288 {
 289   SCM_VALIDATE_MEMOIZED (1, m);
 290   return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
 291 }
 292 #undef FUNC_NAME
 293
 294 SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
 295             (SCM m),
 296             "Return the environment of the memoized expression @var{m}.")
 297 #define FUNC_NAME s_scm_memoized_environment
 298 {
 299   SCM_VALIDATE_MEMOIZED (1, m);
 300   return SCM_MEMOIZED_ENV (m);
 301 }
 302 #undef FUNC_NAME
 303
 304 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 305             (SCM proc),
 306             "Return the name of the procedure @var{proc}")
 307 #define FUNC_NAME s_scm_procedure_name
 308 {
 309   SCM_VALIDATE_PROC (1, proc);
 310   switch (SCM_TYP7 (proc)) {
 311   case scm_tcs_subrs:
 312     return SCM_SUBR_NAME (proc);
 313   default:
 314     {
 315       SCM name = scm_procedure_property (proc, scm_sym_name);
 316 #if 0
 317       /* Source property scm_sym_procname not implemented yet... */
 318       SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
 319       if (scm_is_false (name))
 320         name = scm_procedure_property (proc, scm_sym_name);
 321 #endif
 322       if (scm_is_false (name) && SCM_CLOSUREP (proc))
 323         name = scm_reverse_lookup (SCM_ENV (proc), proc);
 324       if (scm_is_false (name) && SCM_PROGRAM_P (proc))
 325         name = scm_program_name (proc);
 326       return name;
 327     }
 328   }
 329 }
 330 #undef FUNC_NAME
 331
 332 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 333             (SCM proc),
 334             "Return the source of the procedure @var{proc}.")
 335 #define FUNC_NAME s_scm_procedure_source
 336 {
 337   SCM_VALIDATE_NIM (1, proc);
 338  again:
 339   switch (SCM_TYP7 (proc)) {
 340   case scm_tcs_closures:
 341     {
 342       const SCM formals = SCM_CLOSURE_FORMALS (proc);
 343       const SCM body = SCM_CLOSURE_BODY (proc);
 344       const SCM src = scm_source_property (body, scm_sym_copy);
 345
 346       if (scm_is_true (src))
 347         {
 348           return scm_cons2 (scm_sym_lambda, formals, src);
 349         }
 350       else
 351         {
 352           const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
 353           return scm_cons2 (scm_sym_lambda,
 354                             scm_i_finite_list_copy (formals),
 355                             scm_i_unmemocopy_body (body, env));
 356         }
 357     }
 358   case scm_tcs_struct:
 359     if (!SCM_I_OPERATORP (proc))
 360       break;
 361     goto procprop;
 362   case scm_tc7_smob:
 363     if (!SCM_SMOB_DESCRIPTOR (proc).apply)
 364       break;
 365   case scm_tcs_subrs:
 366   case scm_tc7_program:
 367   procprop:
 368     /* It would indeed be a nice thing if we supplied source even for
 369        built in procedures! */
 370     return scm_procedure_property (proc, scm_sym_source);
 371   case scm_tc7_pws:
 372     {
 373       SCM src = scm_procedure_property (proc, scm_sym_source);
 374       if (scm_is_true (src))
 375         return src;
 376       proc = SCM_PROCEDURE (proc);
 377       goto again;
 378     }
 379   default:
 380     ;
 381   }
 382   SCM_WRONG_TYPE_ARG (1, proc);
 383   return SCM_BOOL_F; /* not reached */
 384 }
 385 #undef FUNC_NAME
 386
 387 SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
 388             (SCM proc),
 389             "Return the environment of the procedure @var{proc}.")
 390 #define FUNC_NAME s_scm_procedure_environment
 391 {
 392   SCM_VALIDATE_NIM (1, proc);
 393   switch (SCM_TYP7 (proc)) {
 394   case scm_tcs_closures:
 395     return SCM_ENV (proc);
 396   case scm_tcs_subrs:
 397     return SCM_EOL;
 398   default:
 399     SCM_WRONG_TYPE_ARG (1, proc);
 400     /* not reached */
 401   }
 402 }
 403 #undef FUNC_NAME
 404
 405 SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
 406            (SCM proc),
 407             "Return the module that was current when @var{proc} was defined.")
 408 #define FUNC_NAME s_scm_procedure_module
 409 {
 410   SCM_VALIDATE_PROC (SCM_ARG1, proc);
 411
 412   if (scm_is_true (scm_program_p (proc)))
 413     return scm_program_module (proc);
 414   else
 415     return scm_env_module (scm_procedure_environment (proc));
 416 }
 417 #undef FUNC_NAME
 418
 419
 420 \f
 421
 422 /* Eval in a local environment.  We would like to have the ability to
 423  * evaluate in a specified local environment, but due to the
 424  * memoization this isn't normally possible.  We solve it by copying
 425  * the code before evaluating.  One solution would be to have eval.c
 426  * generate yet another evaluator.  They are not very big actually.
 427  */
 428 SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
 429             (SCM exp, SCM env),
 430             "Evaluate @var{exp} in its environment.  If @var{env} is supplied,\n"
 431             "it is the environment in which to evaluate @var{exp}.  Otherwise,\n"
 432             "@var{exp} must be a memoized code object (in which case, its environment\n"
 433             "is implicit).")
 434 #define FUNC_NAME s_scm_local_eval
 435 {
 436   if (SCM_UNBNDP (env))
 437   {
 438     SCM_VALIDATE_MEMOIZED (1, exp);
 439     return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
 440   }
 441   return scm_i_eval (exp, env);
 442 }
 443 #undef FUNC_NAME
 444
 445 #if 0
 446 SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
 447 #endif
 448
 449 SCM
 450 scm_reverse_lookup (SCM env, SCM data)
 451 {
 452   while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
 453     {
 454       SCM names = SCM_CAAR (env);
 455       SCM values = SCM_CDAR (env);
 456       while (scm_is_pair (names))
 457         {
 458           if (scm_is_eq (SCM_CAR (values), data))
 459             return SCM_CAR (names);
 460           names = SCM_CDR (names);
 461           values = SCM_CDR (values);
 462         }
 463       if (!scm_is_null (names) && scm_is_eq (values, data))
 464         return names;
 465       env = SCM_CDR (env);
 466     }
 467   return SCM_BOOL_F;
 468 }
 469
 470 SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
 471             (SCM id, SCM thunk),
 472             "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
 473 #define FUNC_NAME s_scm_sys_start_stack
 474 {
 475   SCM answer;
 476   scm_t_debug_frame vframe;
 477   scm_t_debug_info vframe_vect_body;
 478   vframe.prev = scm_i_last_debug_frame ();
 479   vframe.status = SCM_VOIDFRAME;
 480   vframe.vect = &vframe_vect_body;
 481   vframe.vect[0].id = id;
 482   scm_i_set_last_debug_frame (&vframe);
 483   answer = scm_call_0 (thunk);
 484   scm_i_set_last_debug_frame (vframe.prev);
 485   return answer;
 486 }
 487 #undef FUNC_NAME
 488
 489 /* {Debug Objects}
 490  *
 491  * The debugging evaluator throws these on frame traps.
 492  */
 493
 494 scm_t_bits scm_tc16_debugobj;
 495
 496 static int
 497 debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
 498 {
 499   scm_puts ("#<debug-object ", port);
 500   scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
 501   scm_putc ('>', port);
 502   return 1;
 503 }
 504
 505 SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
 506             (SCM obj),
 507             "Return @code{#t} if @var{obj} is a debug object.")
 508 #define FUNC_NAME s_scm_debug_object_p
 509 {
 510   return scm_from_bool(SCM_DEBUGOBJP (obj));
 511 }
 512 #undef FUNC_NAME
 513
 514
 515 SCM
 516 scm_make_debugobj (scm_t_debug_frame *frame)
 517 {
 518   return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
 519 }
 520
 521 \f
 522
 523 /* Undocumented debugging procedure */
 524 #ifdef GUILE_DEBUG
 525 SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 526             (SCM obj),
 527             "Go into an endless loop, which can be only terminated with\n"
 528             "a debugger.")
 529 #define FUNC_NAME s_scm_debug_hang
 530 {
 531   int go = 0;
 532   while (!go) ;
 533   return SCM_UNSPECIFIED;
 534 }
 535 #undef FUNC_NAME
 536 #endif
 537
 538 static void
 539 init_stack_limit (void)
 540 {
 541 #ifdef HAVE_GETRLIMIT
 542   struct rlimit lim;
 543   if (getrlimit (RLIMIT_STACK, &lim) == 0)
 544       {
 545         rlim_t bytes = lim.rlim_cur;
 546
 547         /* set our internal stack limit to 80% of the rlimit. */
 548         if (bytes == RLIM_INFINITY)
 549           bytes = lim.rlim_max;
 550
 551         if (bytes != RLIM_INFINITY)
 552           SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
 553       }
 554   errno = 0;
 555 #endif
 556 }
 557
 558 \f
 559
 560 void
 561 scm_init_debug ()
 562 {
 563   init_stack_limit ();
 564   scm_init_opts (scm_debug_options, scm_debug_opts);
 565
 566   scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
 567   scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
 568   scm_set_smob_print (scm_tc16_memoized, memoized_print);
 569
 570   scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
 571   scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
 572
 573 #ifdef GUILE_DEBUG
 574   scm_c_define ("SCM_IM_AND", SCM_IM_AND);
 575   scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
 576   scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
 577   scm_c_define ("SCM_IM_COND", SCM_IM_COND);
 578   scm_c_define ("SCM_IM_DO", SCM_IM_DO);
 579   scm_c_define ("SCM_IM_IF", SCM_IM_IF);
 580   scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
 581   scm_c_define ("SCM_IM_LET", SCM_IM_LET);
 582   scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
 583   scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
 584   scm_c_define ("SCM_IM_OR", SCM_IM_OR);
 585   scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
 586   scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
 587   scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
 588   scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
 589   scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
 590   scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
 591 #endif
 592   scm_add_feature ("debug-extensions");
 593
 594 #include "libguile/debug.x"
 595 }
 596
 597 /*
 598   Local Variables:
 599   c-file-style: "gnu"
 600   End:
 601 */