libguile/frames.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <stdlib.h>
  24 #include <string.h>
  25 #include "_scm.h"
  26 #include "frames.h"
  27 #include <verify.h>
  28
  29 /* Make sure assumptions on the layout of `struct scm_vm_frame' hold.  */
  30 verify (sizeof (SCM) == sizeof (SCM *));
  31 verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM));
  32 verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
  33
  34 \f
  35 #define RELOC(frame, val)                               \
  36   (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
  37
  38 SCM
  39 scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
  40                   scm_t_uint8 *ip, scm_t_ptrdiff offset)
  41 {
  42   struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  43                                        "vmframe");
  44   p->stack_holder = stack_holder;
  45   p->fp = fp;
  46   p->sp = sp;
  47   p->ip = ip;
  48   p->offset = offset;
  49   return scm_cell (scm_tc7_frame, (scm_t_bits)p);
  50 }
  51
  52 void
  53 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  54 {
  55   scm_puts_unlocked ("#<frame ", port);
  56   scm_uintprint (SCM_UNPACK (frame), 16, port);
  57   scm_putc_unlocked (' ', port);
  58   scm_write (scm_frame_procedure (frame), port);
  59   /* don't write args, they can get us into trouble. */
  60   scm_puts_unlocked (">", port);
  61 }
  62
  63 \f
  64 /* Scheme interface */
  65
  66 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
  67             (SCM obj),
  68             "")
  69 #define FUNC_NAME s_scm_frame_p
  70 {
  71   return scm_from_bool (SCM_VM_FRAME_P (obj));
  72 }
  73 #undef FUNC_NAME
  74
  75 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
  76             (SCM frame),
  77             "")
  78 #define FUNC_NAME s_scm_frame_procedure
  79 {
  80   SCM_VALIDATE_VM_FRAME (1, frame);
  81   return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
  82 }
  83 #undef FUNC_NAME
  84
  85 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
  86             (SCM frame),
  87             "")
  88 #define FUNC_NAME s_scm_frame_arguments
  89 {
  90   static SCM var = SCM_BOOL_F;
  91
  92   SCM_VALIDATE_VM_FRAME (1, frame);
  93
  94   if (scm_is_false (var))
  95     var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
  96                                "frame-arguments");
  97
  98   return scm_call_1 (SCM_VARIABLE_REF (var), frame);
  99 }
 100 #undef FUNC_NAME
 101
 102 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 103             (SCM frame),
 104             "")
 105 #define FUNC_NAME s_scm_frame_source
 106 {
 107   SCM proc;
 108
 109   SCM_VALIDATE_VM_FRAME (1, frame);
 110
 111   proc = scm_frame_procedure (frame);
 112
 113   if (SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
 114     return scm_program_source (scm_frame_procedure (frame),
 115                                scm_frame_instruction_pointer (frame),
 116                                SCM_UNDEFINED);
 117
 118   return SCM_BOOL_F;
 119 }
 120 #undef FUNC_NAME
 121
 122 /* The number of locals would be a simple thing to compute, if it weren't for
 123    the presence of not-yet-active frames on the stack. So we have a cheap
 124    heuristic to detect not-yet-active frames, and skip over them. Perhaps we
 125    should represent them more usefully.
 126 */
 127 SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 128             (SCM frame),
 129             "")
 130 #define FUNC_NAME s_scm_frame_num_locals
 131 {
 132   SCM *fp, *sp, *p;
 133   unsigned int n = 0;
 134
 135   SCM_VALIDATE_VM_FRAME (1, frame);
 136
 137   fp = SCM_VM_FRAME_FP (frame);
 138   sp = SCM_VM_FRAME_SP (frame);
 139   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
 140
 141   if (SCM_RTL_PROGRAM_P (fp[-1]))
 142     /* The frame size of an RTL program is fixed, except in the case of
 143        passing a wrong number of arguments to the program.  So we do
 144        need to use an SP for determining the number of locals.  */
 145     return scm_from_ptrdiff_t (sp + 1 - p);
 146
 147   sp = SCM_VM_FRAME_SP (frame);
 148   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
 149   while (p <= sp)
 150     {
 151       if (SCM_UNPACK (p[0]) == 0)
 152         /* skip over not-yet-active frame */
 153         p += 3;
 154       else
 155         {
 156           p++;
 157           n++;
 158         }
 159     }
 160   return scm_from_uint (n);
 161 }
 162 #undef FUNC_NAME
 163
 164 /* Need same not-yet-active frame logic here as in frame-num-locals */
 165 SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
 166             (SCM frame, SCM index),
 167             "")
 168 #define FUNC_NAME s_scm_frame_local_ref
 169 {
 170   SCM *sp, *p;
 171   unsigned int n = 0;
 172   unsigned int i;
 173
 174   SCM_VALIDATE_VM_FRAME (1, frame);
 175   SCM_VALIDATE_UINT_COPY (2, index, i);
 176
 177   sp = SCM_VM_FRAME_SP (frame);
 178   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
 179   while (p <= sp)
 180     {
 181       if (SCM_UNPACK (p[0]) == 0)
 182         /* skip over not-yet-active frame */
 183         p += 3;
 184       else if (n == i)
 185         return *p;
 186       else
 187         {
 188           p++;
 189           n++;
 190         }
 191     }
 192   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 193 }
 194 #undef FUNC_NAME
 195
 196 /* Need same not-yet-active frame logic here as in frame-num-locals */
 197 SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 198             (SCM frame, SCM index, SCM val),
 199             "")
 200 #define FUNC_NAME s_scm_frame_local_set_x
 201 {
 202   SCM *sp, *p;
 203   unsigned int n = 0;
 204   unsigned int i;
 205
 206   SCM_VALIDATE_VM_FRAME (1, frame);
 207   SCM_VALIDATE_UINT_COPY (2, index, i);
 208
 209   sp = SCM_VM_FRAME_SP (frame);
 210   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
 211   while (p <= sp)
 212     {
 213       if (SCM_UNPACK (p[0]) == 0)
 214         /* skip over not-yet-active frame */
 215         p += 3;
 216       else if (n == i)
 217         {
 218           *p = val;
 219           return SCM_UNSPECIFIED;
 220         }
 221       else
 222         {
 223           p++;
 224           n++;
 225         }
 226     }
 227   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 228 }
 229 #undef FUNC_NAME
 230
 231 SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 232             (SCM frame),
 233             "Return the frame pointer for @var{frame}.")
 234 #define FUNC_NAME s_scm_frame_address
 235 {
 236   SCM_VALIDATE_VM_FRAME (1, frame);
 237   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
 238 }
 239 #undef FUNC_NAME
 240
 241 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
 242             (SCM frame),
 243             "")
 244 #define FUNC_NAME s_scm_frame_stack_pointer
 245 {
 246   SCM_VALIDATE_VM_FRAME (1, frame);
 247
 248   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
 249 }
 250 #undef FUNC_NAME
 251
 252 SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
 253             (SCM frame),
 254             "")
 255 #define FUNC_NAME s_scm_frame_instruction_pointer
 256 {
 257   SCM program;
 258   const struct scm_objcode *c_objcode;
 259
 260   SCM_VALIDATE_VM_FRAME (1, frame);
 261   program = scm_frame_procedure (frame);
 262
 263   if (SCM_RTL_PROGRAM_P (program))
 264     return scm_from_ptrdiff_t (SCM_VM_FRAME_IP (frame) -
 265                                (scm_t_uint8 *) SCM_RTL_PROGRAM_CODE (program));
 266
 267   if (!SCM_PROGRAM_P (program))
 268     return SCM_INUM0;
 269
 270   c_objcode = SCM_PROGRAM_DATA (program);
 271   return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
 272                                      - SCM_C_OBJCODE_BASE (c_objcode)));
 273 }
 274 #undef FUNC_NAME
 275
 276 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 277             (SCM frame),
 278             "")
 279 #define FUNC_NAME s_scm_frame_return_address
 280 {
 281   SCM_VALIDATE_VM_FRAME (1, frame);
 282   return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
 283                                               (SCM_VM_FRAME_FP (frame))));
 284 }
 285 #undef FUNC_NAME
 286
 287 SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
 288             (SCM frame),
 289             "")
 290 #define FUNC_NAME s_scm_frame_mv_return_address
 291 {
 292   SCM_VALIDATE_VM_FRAME (1, frame);
 293   return scm_from_uintptr_t ((scm_t_uintptr)
 294                              (SCM_FRAME_MV_RETURN_ADDRESS
 295                               (SCM_VM_FRAME_FP (frame))));
 296 }
 297 #undef FUNC_NAME
 298
 299 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 300             (SCM frame),
 301             "")
 302 #define FUNC_NAME s_scm_frame_dynamic_link
 303 {
 304   SCM_VALIDATE_VM_FRAME (1, frame);
 305   /* fixme: munge fp if holder is a continuation */
 306   return scm_from_uintptr_t
 307     ((scm_t_uintptr)
 308      RELOC (frame,
 309             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 310 }
 311 #undef FUNC_NAME
 312
 313 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 314             (SCM frame),
 315             "")
 316 #define FUNC_NAME s_scm_frame_previous
 317 {
 318   SCM *this_fp, *new_fp, *new_sp;
 319   SCM proc;
 320
 321   SCM_VALIDATE_VM_FRAME (1, frame);
 322
 323  again:
 324   this_fp = SCM_VM_FRAME_FP (frame);
 325   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 326   if (new_fp)
 327     {
 328       new_fp = RELOC (frame, new_fp);
 329       new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
 330       frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
 331                                 new_fp, new_sp,
 332                                 SCM_FRAME_RETURN_ADDRESS (this_fp),
 333                                 SCM_VM_FRAME_OFFSET (frame));
 334       proc = scm_frame_procedure (frame);
 335
 336       if ((SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
 337           && SCM_PROGRAM_IS_BOOT (proc))
 338         goto again;
 339       else
 340         return frame;
 341     }
 342   else
 343     return SCM_BOOL_F;
 344 }
 345 #undef FUNC_NAME
 346
 347 \f
 348 void
 349 scm_init_frames (void)
 350 {
 351 #ifndef SCM_MAGIC_SNARFER
 352 #include "libguile/frames.x"
 353 #endif
 354 }
 355
 356 /*
 357   Local Variables:
 358   c-file-style: "gnu"
 359   End:
 360 */