libguile/stacks.c

   1 /* A stack holds a frame chain
   2  * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/control.h"
  28 #include "libguile/eval.h"
  29 #include "libguile/debug.h"
  30 #include "libguile/continuations.h"
  31 #include "libguile/struct.h"
  32 #include "libguile/macros.h"
  33 #include "libguile/procprop.h"
  34 #include "libguile/modules.h"
  35 #include "libguile/root.h"
  36 #include "libguile/strings.h"
  37 #include "libguile/vm.h" /* to capture vm stacks */
  38 #include "libguile/frames.h" /* vm frames */
  39
  40 #include "libguile/validate.h"
  41 #include "libguile/stacks.h"
  42 #include "libguile/private-options.h"
  43
  44
  45 static SCM scm_sys_stacks;
  46
  47 \f
  48 /* {Stacks}
  49  *
  50  * The stack is represented as a struct that holds a frame. The frame itself is
  51  * linked to the next frame, or #f.
  52  *
  53  * Stacks
  54  *   Constructor
  55  *     make-stack
  56  *   Selectors
  57  *     stack-id
  58  *     stack-ref
  59  *   Inspector
  60  *     stack-length
  61  */
  62
  63 \f
  64
  65 /* Count number of debug info frames on a stack, beginning with FRAME.
  66  */
  67 static long
  68 stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  69 {
  70   struct scm_frame tmp;
  71   long n = 1;
  72   memcpy (&tmp, frame, sizeof tmp);
  73   while (scm_c_frame_previous (kind, &tmp))
  74     ++n;
  75   return n;
  76 }
  77
  78 /* Narrow STACK by cutting away stackframes (mutatingly).
  79  *
  80  * Inner frames (most recent) are cut by advancing the frames pointer.
  81  * Outer frames are cut by decreasing the recorded length.
  82  *
  83  * Cut maximally INNER inner frames and OUTER outer frames using
  84  * the keys INNER_KEY and OUTER_KEY.
  85  *
  86  * Frames are cut away starting at the end points and moving towards
  87  * the center of the stack.  The key is normally compared to the
  88  * operator in application frames.  Frames up to and including the key
  89  * are cut.
  90  *
  91  * If INNER_KEY is #t a different scheme is used for inner frames:
  92  *
  93  * Frames up to but excluding the first source frame originating from
  94  * a user module are cut, except for possible application frames
  95  * between the user frame and the last system frame previously
  96  * encountered.
  97  */
  98
  99 static scm_t_ptrdiff
 100 find_prompt (SCM key)
 101 {
 102   scm_t_ptrdiff fp_offset;
 103
 104   if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
 105                                  NULL, &fp_offset, NULL, NULL, NULL))
 106     scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
 107                     scm_list_1 (key));
 108
 109   return fp_offset;
 110 }
 111
 112 static long
 113 narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
 114               SCM inner_cut, SCM outer_cut)
 115 {
 116   /* Resolve procedure cuts to address ranges, if possible.  If the
 117      debug information has been stripped, this might not be
 118      possible.  */
 119   if (scm_is_true (scm_program_p (inner_cut)))
 120     {
 121       SCM addr_range = scm_program_address_range (inner_cut);
 122       if (scm_is_pair (addr_range))
 123         inner_cut = addr_range;
 124     }
 125   if (scm_is_true (scm_program_p (outer_cut)))
 126     {
 127       SCM addr_range = scm_program_address_range (outer_cut);
 128       if (scm_is_pair (addr_range))
 129         outer_cut = addr_range;
 130     }
 131
 132   /* Cut inner part. */
 133   if (scm_is_true (scm_procedure_p (inner_cut)))
 134     {
 135       /* Cut until the given procedure is seen. */
 136       for (; len ;)
 137         {
 138           SCM proc = scm_c_frame_closure (kind, frame);
 139           len--;
 140           scm_c_frame_previous (kind, frame);
 141           if (scm_is_eq (proc, inner_cut))
 142             break;
 143         }
 144     }
 145   else if (scm_is_pair (inner_cut)
 146            && scm_is_integer (scm_car (inner_cut))
 147            && scm_is_integer (scm_cdr (inner_cut)))
 148     {
 149       /* Cut until an IP within the given range is found.  */
 150       scm_t_uintptr low_pc, high_pc, pc;
 151
 152       low_pc = scm_to_uintptr_t (scm_car (inner_cut));
 153       high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
 154
 155       for (; len ;)
 156         {
 157           pc = (scm_t_uintptr) frame->ip;
 158           len--;
 159           scm_c_frame_previous (kind, frame);
 160           if (low_pc <= pc && pc < high_pc)
 161             break;
 162         }
 163     }
 164   else if (scm_is_integer (inner_cut))
 165     {
 166       /* Cut specified number of frames. */
 167       long inner = scm_to_int (inner_cut);
 168
 169       for (; inner && len; --inner)
 170         {
 171           len--;
 172           scm_c_frame_previous (kind, frame);
 173         }
 174     }
 175   else
 176     {
 177       /* Cut until the given prompt tag is seen. */
 178       scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
 179       for (; len; len--, scm_c_frame_previous (kind, frame))
 180         if (fp_offset == frame->fp_offset)
 181           break;
 182     }
 183
 184   /* Cut outer part. */
 185   if (scm_is_true (scm_procedure_p (outer_cut)))
 186     {
 187       long i, new_len;
 188       struct scm_frame tmp;
 189
 190       memcpy (&tmp, frame, sizeof tmp);
 191
 192       /* Cut until the given procedure is seen. */
 193       for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
 194         if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
 195           new_len = i;
 196
 197       len = new_len;
 198     }
 199   else if (scm_is_pair (outer_cut)
 200            && scm_is_integer (scm_car (outer_cut))
 201            && scm_is_integer (scm_cdr (outer_cut)))
 202     {
 203       /* Cut until an IP within the given range is found.  */
 204       scm_t_uintptr low_pc, high_pc, pc;
 205       long i, new_len;
 206       struct scm_frame tmp;
 207
 208       low_pc = scm_to_uintptr_t (scm_car (outer_cut));
 209       high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
 210
 211       memcpy (&tmp, frame, sizeof tmp);
 212
 213       /* Cut until the given procedure is seen. */
 214       for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
 215         {
 216           pc = (scm_t_uintptr) tmp.ip;
 217           if (low_pc <= pc && pc < high_pc)
 218             new_len = i;
 219         }
 220
 221       len = new_len;
 222     }
 223   else if (scm_is_integer (outer_cut))
 224     {
 225       /* Cut specified number of frames. */
 226       long outer = scm_to_int (outer_cut);
 227
 228       if (outer < len)
 229         len -= outer;
 230       else
 231         len = 0;
 232     }
 233   else
 234     {
 235       /* Cut until the given prompt tag is seen. */
 236       long i;
 237       struct scm_frame tmp;
 238       scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
 239
 240       memcpy (&tmp, frame, sizeof tmp);
 241
 242       for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
 243         if (tmp.fp_offset == fp_offset)
 244           break;
 245
 246       if (i < len)
 247         len = i;
 248       else
 249         len = 0;
 250     }
 251
 252   return len;
 253 }
 254
 255 \f
 256
 257 /* Stacks
 258  */
 259
 260 SCM scm_stack_type;
 261
 262 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 263             (SCM obj),
 264             "Return @code{#t} if @var{obj} is a calling stack.")
 265 #define FUNC_NAME s_scm_stack_p
 266 {
 267   return scm_from_bool(SCM_STACKP (obj));
 268 }
 269 #undef FUNC_NAME
 270
 271 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 272             (SCM obj, SCM args),
 273             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 274             "evaluation stack is used for creating the stack frames,\n"
 275             "otherwise the frames are taken from @var{obj} (which must be\n"
 276             "a continuation or a frame object).\n"
 277             "\n"
 278             "@var{args} should be a list containing any combination of\n"
 279             "integer, procedure, address range, prompt tag and @code{#t}\n"
 280             "values.\n"
 281             "\n"
 282             "These values specify various ways of cutting away uninteresting\n"
 283             "stack frames from the top and bottom of the stack that\n"
 284             "@code{make-stack} returns.  They come in pairs like this:\n"
 285             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 286             "@var{outer_cut_2} @dots{})}.\n"
 287             "\n"
 288             "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
 289             "address range, or a prompt tag.  An integer means to cut away\n"
 290             "exactly that number of frames.  A procedure means to cut\n"
 291             "away all frames up to but excluding the frame whose procedure\n"
 292             "matches the specified one.  An address range is a pair of\n"
 293             "integers indicating the low and high addresses of a procedure's\n"
 294             "code, and is the same as cutting away to a procedure (though\n"
 295             "with less work).  Anything else is interpreted as a prompt tag\n"
 296             "which cuts away all frames that are inside a prompt with the\n"
 297             "given tag.\n"
 298             "\n"
 299             "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
 300             "address range, or a prompt tag.  An integer means to cut away\n"
 301             "that number of frames.  A procedure means to cut away frames\n"
 302             "down to but excluding the frame whose procedure matches the\n"
 303             "specified one.  An address range is the same, but with the\n"
 304             "procedure's code specified as an address range.  Anything else\n"
 305             "is taken to be a prompt tag, which cuts away all frames that are\n"
 306             "outside a prompt with the given tag.\n"
 307             "\n"
 308             "If the @var{outer_cut_i} of the last pair is missing, it is\n"
 309             "taken as 0.")
 310 #define FUNC_NAME s_scm_make_stack
 311 {
 312   long n;
 313   SCM inner_cut, outer_cut;
 314   enum scm_vm_frame_kind kind;
 315   struct scm_frame frame;
 316
 317   /* Extract a pointer to the innermost frame of whatever object
 318      scm_make_stack was given.  */
 319   if (scm_is_eq (obj, SCM_BOOL_T))
 320     {
 321       SCM cont;
 322       struct scm_vm_cont *c;
 323
 324       cont = scm_i_capture_current_stack ();
 325       c = SCM_VM_CONT_DATA (cont);
 326
 327       kind = SCM_VM_FRAME_KIND_CONT;
 328       frame.stack_holder = c;
 329       frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
 330       frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
 331       frame.ip = c->ra;
 332     }
 333   else if (SCM_VM_FRAME_P (obj))
 334     {
 335       kind = SCM_VM_FRAME_KIND (obj);
 336       memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
 337     }
 338   else if (SCM_CONTINUATIONP (obj))
 339     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
 340        that were in place when the continuation was captured. */
 341     {
 342       kind = SCM_VM_FRAME_KIND_CONT;
 343       if (!scm_i_continuation_to_frame (obj, &frame))
 344         return SCM_BOOL_F;
 345     }
 346   else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
 347     {
 348       kind = SCM_VM_FRAME_KIND_CONT;
 349       if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
 350                                    &frame))
 351         return SCM_BOOL_F;
 352     }
 353   else
 354     {
 355       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 356       /* not reached */
 357     }
 358
 359   /* Skip initial boot frame, if any.  This is possible if the frame
 360      originates from a captured continuation.  */
 361   if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
 362       && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
 363       && !scm_c_frame_previous (kind, &frame))
 364     return SCM_BOOL_F;
 365
 366   /* Count number of frames.  Also get stack id tag and check whether
 367      there are more stackframes than we want to record
 368      (SCM_BACKTRACE_MAXDEPTH). */
 369   n = stack_depth (kind, &frame);
 370
 371   /* Narrow the stack according to the arguments given to scm_make_stack. */
 372   SCM_VALIDATE_REST_ARGUMENT (args);
 373   while (n > 0 && !scm_is_null (args))
 374     {
 375       inner_cut = SCM_CAR (args);
 376       args = SCM_CDR (args);
 377       if (scm_is_null (args))
 378         {
 379           outer_cut = SCM_INUM0;
 380         }
 381       else
 382         {
 383           outer_cut = SCM_CAR (args);
 384           args = SCM_CDR (args);
 385         }
 386
 387       n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
 388     }
 389
 390   if (n > 0)
 391     {
 392       /* Make the stack object. */
 393       SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
 394       SCM_SET_STACK_LENGTH (stack, n);
 395       SCM_SET_STACK_ID (stack, scm_stack_id (obj));
 396       SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
 397       return stack;
 398     }
 399   else
 400     return SCM_BOOL_F;
 401 }
 402 #undef FUNC_NAME
 403
 404 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 405             (SCM stack),
 406             "Return the identifier given to @var{stack} by @code{start-stack}.")
 407 #define FUNC_NAME s_scm_stack_id
 408 {
 409   if (scm_is_eq (stack, SCM_BOOL_T)
 410       /* FIXME: frame case assumes frame still live on the stack, and no
 411          intervening start-stack. Hmm... */
 412       || SCM_VM_FRAME_P (stack))
 413     {
 414       /* Fetch most recent start-stack tag. */
 415       SCM stacks = scm_fluid_ref (scm_sys_stacks);
 416       return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
 417     }
 418   else if (SCM_CONTINUATIONP (stack))
 419     /* FIXME: implement me */
 420     return SCM_BOOL_F;
 421   else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
 422     /* FIXME: implement me */
 423     return SCM_BOOL_F;
 424   else
 425     {
 426       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
 427       /* not reached */
 428     }
 429 }
 430 #undef FUNC_NAME
 431
 432 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 433             (SCM stack, SCM index),
 434             "Return the @var{index}'th frame from @var{stack}.")
 435 #define FUNC_NAME s_scm_stack_ref
 436 {
 437   unsigned long int c_index;
 438   SCM frame;
 439
 440   SCM_VALIDATE_STACK (1, stack);
 441   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 442   frame = SCM_STACK_FRAME (stack);
 443   while (c_index--)
 444     frame = scm_frame_previous (frame);
 445   return frame;
 446 }
 447 #undef FUNC_NAME
 448
 449 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 450             (SCM stack),
 451             "Return the length of @var{stack}.")
 452 #define FUNC_NAME s_scm_stack_length
 453 {
 454   SCM_VALIDATE_STACK (1, stack);
 455   return scm_from_long (SCM_STACK_LENGTH (stack));
 456 }
 457 #undef FUNC_NAME
 458
 459 \f
 460
 461 void
 462 scm_init_stacks ()
 463 {
 464   scm_sys_stacks = scm_make_fluid ();
 465   scm_c_define ("%stacks", scm_sys_stacks);
 466
 467   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 468                                     SCM_UNDEFINED);
 469   scm_set_struct_vtable_name_x (scm_stack_type,
 470                                 scm_from_latin1_symbol ("stack"));
 471 #include "libguile/stacks.x"
 472 }
 473
 474 /*
 475   Local Variables:
 476   c-file-style: "gnu"
 477   End:
 478 */