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   /* Cut inner part. */
 117   if (scm_is_true (scm_procedure_p (inner_cut)))
 118     {
 119       /* Cut until the given procedure is seen. */
 120       for (; len ;)
 121         {
 122           SCM proc = scm_c_frame_closure (kind, frame);
 123           len--;
 124           scm_c_frame_previous (kind, frame);
 125           if (scm_is_eq (proc, inner_cut))
 126             break;
 127         }
 128     }
 129   else if (scm_is_integer (inner_cut))
 130     {
 131       /* Cut specified number of frames. */
 132       long inner = scm_to_int (inner_cut);
 133
 134       for (; inner && len; --inner)
 135         {
 136           len--;
 137           scm_c_frame_previous (kind, frame);
 138         }
 139     }
 140   else
 141     {
 142       /* Cut until the given prompt tag is seen. */
 143       scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
 144       for (; len; len--, scm_c_frame_previous (kind, frame))
 145         if (fp_offset == frame->fp_offset)
 146           break;
 147     }
 148
 149   /* Cut outer part. */
 150   if (scm_is_true (scm_procedure_p (outer_cut)))
 151     {
 152       long i, new_len;
 153       struct scm_frame tmp;
 154
 155       memcpy (&tmp, frame, sizeof tmp);
 156
 157       /* Cut until the given procedure is seen. */
 158       for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
 159         if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
 160           new_len = i;
 161
 162       len = new_len;
 163     }
 164   else if (scm_is_integer (outer_cut))
 165     {
 166       /* Cut specified number of frames. */
 167       long outer = scm_to_int (outer_cut);
 168
 169       if (outer < len)
 170         len -= outer;
 171       else
 172         len = 0;
 173     }
 174   else
 175     {
 176       /* Cut until the given prompt tag is seen. */
 177       long i;
 178       struct scm_frame tmp;
 179       scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
 180
 181       memcpy (&tmp, frame, sizeof tmp);
 182
 183       for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
 184         if (tmp.fp_offset == fp_offset)
 185           break;
 186
 187       if (i < len)
 188         len = i;
 189       else
 190         len = 0;
 191     }
 192
 193   return len;
 194 }
 195
 196 \f
 197
 198 /* Stacks
 199  */
 200
 201 SCM scm_stack_type;
 202
 203 SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
 204             (SCM obj),
 205             "Return @code{#t} if @var{obj} is a calling stack.")
 206 #define FUNC_NAME s_scm_stack_p
 207 {
 208   return scm_from_bool(SCM_STACKP (obj));
 209 }
 210 #undef FUNC_NAME
 211
 212 SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 213             (SCM obj, SCM args),
 214             "Create a new stack. If @var{obj} is @code{#t}, the current\n"
 215             "evaluation stack is used for creating the stack frames,\n"
 216             "otherwise the frames are taken from @var{obj} (which must be\n"
 217             "a continuation or a frame object).\n"
 218             "\n"
 219             "@var{args} should be a list containing any combination of\n"
 220             "integer, procedure, prompt tag and @code{#t} values.\n"
 221             "\n"
 222             "These values specify various ways of cutting away uninteresting\n"
 223             "stack frames from the top and bottom of the stack that\n"
 224             "@code{make-stack} returns.  They come in pairs like this:\n"
 225             "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
 226             "@var{outer_cut_2} @dots{})}.\n"
 227             "\n"
 228             "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n"
 229             "tag, or a procedure.  @code{#t} means to cut away all frames up\n"
 230             "to but excluding the first user module frame.  An integer means\n"
 231             "to cut away exactly that number of frames.  A prompt tag means\n"
 232             "to cut away all frames that are inside a prompt with the given\n"
 233             "tag. A procedure means to cut away all frames up to but\n"
 234             "excluding the application frame whose procedure matches the\n"
 235             "specified one.\n"
 236             "\n"
 237             "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
 238             "procedure.  An integer means to cut away that number of frames.\n"
 239             "A prompt tag means to cut away all frames that are outside a\n"
 240             "prompt with the given tag. A procedure means to cut away\n"
 241             "frames down to but excluding the application frame whose\n"
 242             "procedure matches the specified one.\n"
 243             "\n"
 244             "If the @var{outer_cut_i} of the last pair is missing, it is\n"
 245             "taken as 0.")
 246 #define FUNC_NAME s_scm_make_stack
 247 {
 248   long n;
 249   SCM inner_cut, outer_cut;
 250   enum scm_vm_frame_kind kind;
 251   struct scm_frame frame;
 252
 253   /* Extract a pointer to the innermost frame of whatever object
 254      scm_make_stack was given.  */
 255   if (scm_is_eq (obj, SCM_BOOL_T))
 256     {
 257       SCM cont;
 258       struct scm_vm_cont *c;
 259
 260       cont = scm_i_capture_current_stack ();
 261       c = SCM_VM_CONT_DATA (cont);
 262
 263       kind = SCM_VM_FRAME_KIND_CONT;
 264       frame.stack_holder = c;
 265       frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
 266       frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
 267       frame.ip = c->ra;
 268     }
 269   else if (SCM_VM_FRAME_P (obj))
 270     {
 271       kind = SCM_VM_FRAME_KIND (obj);
 272       memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
 273     }
 274   else if (SCM_CONTINUATIONP (obj))
 275     /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
 276        that were in place when the continuation was captured. */
 277     {
 278       kind = SCM_VM_FRAME_KIND_CONT;
 279       if (!scm_i_continuation_to_frame (obj, &frame))
 280         return SCM_BOOL_F;
 281     }
 282   else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
 283     {
 284       kind = SCM_VM_FRAME_KIND_CONT;
 285       if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
 286                                    &frame))
 287         return SCM_BOOL_F;
 288     }
 289   else
 290     {
 291       SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
 292       /* not reached */
 293     }
 294
 295   /* Skip initial boot frame, if any.  This is possible if the frame
 296      originates from a captured continuation.  */
 297   if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
 298       && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
 299       && !scm_c_frame_previous (kind, &frame))
 300     return SCM_BOOL_F;
 301
 302   /* Count number of frames.  Also get stack id tag and check whether
 303      there are more stackframes than we want to record
 304      (SCM_BACKTRACE_MAXDEPTH). */
 305   n = stack_depth (kind, &frame);
 306
 307   /* Narrow the stack according to the arguments given to scm_make_stack. */
 308   SCM_VALIDATE_REST_ARGUMENT (args);
 309   while (n > 0 && !scm_is_null (args))
 310     {
 311       inner_cut = SCM_CAR (args);
 312       args = SCM_CDR (args);
 313       if (scm_is_null (args))
 314         {
 315           outer_cut = SCM_INUM0;
 316         }
 317       else
 318         {
 319           outer_cut = SCM_CAR (args);
 320           args = SCM_CDR (args);
 321         }
 322
 323       n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
 324     }
 325
 326   if (n > 0)
 327     {
 328       /* Make the stack object. */
 329       SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
 330       SCM_SET_STACK_LENGTH (stack, n);
 331       SCM_SET_STACK_ID (stack, scm_stack_id (obj));
 332       SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
 333       return stack;
 334     }
 335   else
 336     return SCM_BOOL_F;
 337 }
 338 #undef FUNC_NAME
 339
 340 SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
 341             (SCM stack),
 342             "Return the identifier given to @var{stack} by @code{start-stack}.")
 343 #define FUNC_NAME s_scm_stack_id
 344 {
 345   if (scm_is_eq (stack, SCM_BOOL_T)
 346       /* FIXME: frame case assumes frame still live on the stack, and no
 347          intervening start-stack. Hmm... */
 348       || SCM_VM_FRAME_P (stack))
 349     {
 350       /* Fetch most recent start-stack tag. */
 351       SCM stacks = scm_fluid_ref (scm_sys_stacks);
 352       return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
 353     }
 354   else if (SCM_CONTINUATIONP (stack))
 355     /* FIXME: implement me */
 356     return SCM_BOOL_F;
 357   else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
 358     /* FIXME: implement me */
 359     return SCM_BOOL_F;
 360   else
 361     {
 362       SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
 363       /* not reached */
 364     }
 365 }
 366 #undef FUNC_NAME
 367
 368 SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
 369             (SCM stack, SCM index),
 370             "Return the @var{index}'th frame from @var{stack}.")
 371 #define FUNC_NAME s_scm_stack_ref
 372 {
 373   unsigned long int c_index;
 374   SCM frame;
 375
 376   SCM_VALIDATE_STACK (1, stack);
 377   c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
 378   frame = SCM_STACK_FRAME (stack);
 379   while (c_index--)
 380     frame = scm_frame_previous (frame);
 381   return frame;
 382 }
 383 #undef FUNC_NAME
 384
 385 SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
 386             (SCM stack),
 387             "Return the length of @var{stack}.")
 388 #define FUNC_NAME s_scm_stack_length
 389 {
 390   SCM_VALIDATE_STACK (1, stack);
 391   return scm_from_long (SCM_STACK_LENGTH (stack));
 392 }
 393 #undef FUNC_NAME
 394
 395 \f
 396
 397 void
 398 scm_init_stacks ()
 399 {
 400   scm_sys_stacks = scm_make_fluid ();
 401   scm_c_define ("%stacks", scm_sys_stacks);
 402
 403   scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
 404                                     SCM_UNDEFINED);
 405   scm_set_struct_vtable_name_x (scm_stack_type,
 406                                 scm_from_latin1_symbol ("stack"));
 407 #include "libguile/stacks.x"
 408 }
 409
 410 /*
 411   Local Variables:
 412   c-file-style: "gnu"
 413   End:
 414 */