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 "vm.h"
  28 #include <verify.h>
  29
  30 /* Make sure assumptions on the layout of `struct scm_vm_frame' hold.  */
  31 verify (sizeof (SCM) == sizeof (SCM *));
  32 verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM));
  33 verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
  34
  35 \f
  36 #define RELOC(frame, val)                               \
  37   (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
  38
  39 SCM
  40 scm_c_make_frame (enum scm_vm_frame_kind frame_kind, void *stack_holder,
  41                   scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
  42                   scm_t_uint32 *ip)
  43 {
  44   struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  45                                        "vmframe");
  46   p->stack_holder = stack_holder;
  47   p->fp_offset = fp_offset;
  48   p->sp_offset = sp_offset;
  49   p->ip = ip;
  50   return scm_cell (scm_tc7_frame | (frame_kind << 8), (scm_t_bits)p);
  51 }
  52
  53 void
  54 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  55 {
  56   scm_puts_unlocked ("#<frame ", port);
  57   scm_uintprint (SCM_UNPACK (frame), 16, port);
  58   scm_putc_unlocked (' ', port);
  59   scm_write (scm_frame_procedure (frame), port);
  60   /* don't write args, they can get us into trouble. */
  61   scm_puts_unlocked (">", port);
  62 }
  63
  64 SCM*
  65 scm_i_frame_stack_base (SCM frame)
  66 #define FUNC_NAME "frame-stack-base"
  67 {
  68   void *stack_holder;
  69
  70   SCM_VALIDATE_VM_FRAME (1, frame);
  71
  72   stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
  73
  74   switch (SCM_VM_FRAME_KIND (frame))
  75     {
  76       case SCM_VM_FRAME_KIND_CONT:
  77         return ((struct scm_vm_cont *) stack_holder)->stack_base;
  78
  79       case SCM_VM_FRAME_KIND_VM:
  80         return ((struct scm_vm *) stack_holder)->stack_base;
  81
  82       default:
  83         abort ();
  84     }
  85 }
  86 #undef FUNC_NAME
  87
  88 scm_t_ptrdiff
  89 scm_i_frame_offset (SCM frame)
  90 #define FUNC_NAME "frame-offset"
  91 {
  92   void *stack_holder;
  93
  94   SCM_VALIDATE_VM_FRAME (1, frame);
  95
  96   stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
  97
  98   switch (SCM_VM_FRAME_KIND (frame))
  99     {
 100       case SCM_VM_FRAME_KIND_CONT:
 101         return ((struct scm_vm_cont *) stack_holder)->reloc;
 102
 103       case SCM_VM_FRAME_KIND_VM:
 104         return 0;
 105
 106       default:
 107         abort ();
 108     }
 109 }
 110 #undef FUNC_NAME
 111
 112 \f
 113 /* Scheme interface */
 114
 115 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 116             (SCM obj),
 117             "")
 118 #define FUNC_NAME s_scm_frame_p
 119 {
 120   return scm_from_bool (SCM_VM_FRAME_P (obj));
 121 }
 122 #undef FUNC_NAME
 123
 124 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
 125             (SCM frame),
 126             "")
 127 #define FUNC_NAME s_scm_frame_procedure
 128 {
 129   SCM_VALIDATE_VM_FRAME (1, frame);
 130   return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
 131 }
 132 #undef FUNC_NAME
 133
 134 static SCM frame_arguments_var;
 135
 136 static void
 137 init_frame_arguments_var (void)
 138 {
 139   frame_arguments_var
 140     = scm_c_private_lookup ("system vm frame", "frame-arguments");
 141 }
 142
 143 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
 144             (SCM frame),
 145             "")
 146 #define FUNC_NAME s_scm_frame_arguments
 147 {
 148   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 149   scm_i_pthread_once (&once, init_frame_arguments_var);
 150
 151   SCM_VALIDATE_VM_FRAME (1, frame);
 152
 153   return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
 154 }
 155 #undef FUNC_NAME
 156
 157 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 158             (SCM frame),
 159             "")
 160 #define FUNC_NAME s_scm_frame_source
 161 {
 162   SCM_VALIDATE_VM_FRAME (1, frame);
 163
 164   return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
 165 }
 166 #undef FUNC_NAME
 167
 168 SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 169             (SCM frame),
 170             "")
 171 #define FUNC_NAME s_scm_frame_num_locals
 172 {
 173   SCM *fp, *sp;
 174
 175   SCM_VALIDATE_VM_FRAME (1, frame);
 176
 177   fp = SCM_VM_FRAME_FP (frame);
 178   sp = SCM_VM_FRAME_SP (frame);
 179
 180   return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
 181 }
 182 #undef FUNC_NAME
 183
 184 SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
 185             (SCM frame, SCM index),
 186             "")
 187 #define FUNC_NAME s_scm_frame_local_ref
 188 {
 189   SCM *fp, *sp;
 190   unsigned int i;
 191
 192   SCM_VALIDATE_VM_FRAME (1, frame);
 193   SCM_VALIDATE_UINT_COPY (2, index, i);
 194
 195   fp = SCM_VM_FRAME_FP (frame);
 196   sp = SCM_VM_FRAME_SP (frame);
 197
 198   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 199     return SCM_FRAME_LOCAL (fp, i);
 200
 201   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 202 }
 203 #undef FUNC_NAME
 204
 205 /* Need same not-yet-active frame logic here as in frame-num-locals */
 206 SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 207             (SCM frame, SCM index, SCM val),
 208             "")
 209 #define FUNC_NAME s_scm_frame_local_set_x
 210 {
 211   SCM *fp, *sp;
 212   unsigned int i;
 213
 214   SCM_VALIDATE_VM_FRAME (1, frame);
 215   SCM_VALIDATE_UINT_COPY (2, index, i);
 216
 217   fp = SCM_VM_FRAME_FP (frame);
 218   sp = SCM_VM_FRAME_SP (frame);
 219
 220   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 221     {
 222       SCM_FRAME_LOCAL (fp, i) = val;
 223       return SCM_UNSPECIFIED;
 224     }
 225
 226   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 227 }
 228 #undef FUNC_NAME
 229
 230 SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 231             (SCM frame),
 232             "Return the frame pointer for @var{frame}.")
 233 #define FUNC_NAME s_scm_frame_address
 234 {
 235   SCM_VALIDATE_VM_FRAME (1, frame);
 236   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame));
 237 }
 238 #undef FUNC_NAME
 239
 240 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
 241             (SCM frame),
 242             "")
 243 #define FUNC_NAME s_scm_frame_stack_pointer
 244 {
 245   SCM_VALIDATE_VM_FRAME (1, frame);
 246
 247   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame));
 248 }
 249 #undef FUNC_NAME
 250
 251 SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
 252             (SCM frame),
 253             "")
 254 #define FUNC_NAME s_scm_frame_instruction_pointer
 255 {
 256   SCM_VALIDATE_VM_FRAME (1, frame);
 257
 258   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
 259 }
 260 #undef FUNC_NAME
 261
 262 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 263             (SCM frame),
 264             "")
 265 #define FUNC_NAME s_scm_frame_return_address
 266 {
 267   SCM_VALIDATE_VM_FRAME (1, frame);
 268   return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
 269                                               (SCM_VM_FRAME_FP (frame))));
 270 }
 271 #undef FUNC_NAME
 272
 273 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 274             (SCM frame),
 275             "")
 276 #define FUNC_NAME s_scm_frame_dynamic_link
 277 {
 278   SCM_VALIDATE_VM_FRAME (1, frame);
 279   /* fixme: munge fp if holder is a continuation */
 280   return scm_from_uintptr_t
 281     ((scm_t_uintptr)
 282      RELOC (frame,
 283             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 284 }
 285 #undef FUNC_NAME
 286
 287 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 288             (SCM frame),
 289             "")
 290 #define FUNC_NAME s_scm_frame_previous
 291 {
 292   SCM *this_fp, *new_fp, *new_sp;
 293   SCM proc;
 294
 295   SCM_VALIDATE_VM_FRAME (1, frame);
 296
 297  again:
 298   this_fp = SCM_VM_FRAME_FP (frame);
 299   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 300   if (new_fp)
 301     {
 302       SCM *stack_base = scm_i_frame_stack_base (frame);
 303       new_fp = RELOC (frame, new_fp);
 304       new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
 305       frame = scm_c_make_frame (SCM_VM_FRAME_KIND (frame),
 306                                 SCM_VM_FRAME_STACK_HOLDER (frame),
 307                                 new_fp - stack_base, new_sp - stack_base,
 308                                 SCM_FRAME_RETURN_ADDRESS (this_fp));
 309       proc = scm_frame_procedure (frame);
 310
 311       if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
 312         goto again;
 313       else
 314         return frame;
 315     }
 316   else
 317     return SCM_BOOL_F;
 318 }
 319 #undef FUNC_NAME
 320
 321 \f
 322 void
 323 scm_init_frames (void)
 324 {
 325 #ifndef SCM_MAGIC_SNARFER
 326 #include "libguile/frames.x"
 327 #endif
 328 }
 329
 330 /*
 331   Local Variables:
 332   c-file-style: "gnu"
 333   End:
 334 */