libguile/frames.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
  37 SCM
  38 scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  39 {
  40   struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
  41                                        "vmframe");
  42   p->stack_holder = frame->stack_holder;
  43   p->fp_offset = frame->fp_offset;
  44   p->sp_offset = frame->sp_offset;
  45   p->ip = frame->ip;
  46   return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
  47 }
  48
  49 void
  50 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
  51 {
  52   scm_puts_unlocked ("#<frame ", port);
  53   scm_uintprint (SCM_UNPACK (frame), 16, port);
  54   scm_putc_unlocked (' ', port);
  55   scm_write (scm_frame_procedure (frame), port);
  56   /* don't write args, they can get us into trouble. */
  57   scm_puts_unlocked (">", port);
  58 }
  59
  60 static SCM*
  61 frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  62 {
  63   switch (kind)
  64     {
  65       case SCM_VM_FRAME_KIND_CONT:
  66         return ((struct scm_vm_cont *) frame->stack_holder)->stack_base;
  67
  68       case SCM_VM_FRAME_KIND_VM:
  69         return ((struct scm_vm *) frame->stack_holder)->stack_base;
  70
  71       default:
  72         abort ();
  73     }
  74 }
  75
  76 static scm_t_ptrdiff
  77 frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
  78 {
  79   switch (kind)
  80     {
  81     case SCM_VM_FRAME_KIND_CONT:
  82       return ((struct scm_vm_cont *) frame->stack_holder)->reloc;
  83
  84     case SCM_VM_FRAME_KIND_VM:
  85       return 0;
  86
  87     default:
  88       abort ();
  89     }
  90 }
  91
  92 SCM*
  93 scm_i_frame_stack_base (SCM frame)
  94 #define FUNC_NAME "frame-stack-base"
  95 {
  96   SCM_VALIDATE_VM_FRAME (1, frame);
  97
  98   return frame_stack_base (SCM_VM_FRAME_KIND (frame),
  99                            SCM_VM_FRAME_DATA (frame));
 100 }
 101 #undef FUNC_NAME
 102
 103 scm_t_ptrdiff
 104 scm_i_frame_offset (SCM frame)
 105 #define FUNC_NAME "frame-offset"
 106 {
 107   SCM_VALIDATE_VM_FRAME (1, frame);
 108
 109   return frame_offset (SCM_VM_FRAME_KIND (frame),
 110                        SCM_VM_FRAME_DATA (frame));
 111
 112 }
 113 #undef FUNC_NAME
 114
 115 \f
 116 /* Scheme interface */
 117
 118 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 119             (SCM obj),
 120             "")
 121 #define FUNC_NAME s_scm_frame_p
 122 {
 123   return scm_from_bool (SCM_VM_FRAME_P (obj));
 124 }
 125 #undef FUNC_NAME
 126
 127 /* Retrieve the local in slot 0, which may or may not actually be a
 128    procedure, and may or may not actually be the procedure being
 129    applied.  If you want the procedure, look it up from the IP.  */
 130 SCM
 131 scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
 132 {
 133   SCM *fp, *sp;
 134
 135   fp = frame_stack_base (kind, frame) + frame->fp_offset;
 136   sp = frame_stack_base (kind, frame) + frame->sp_offset;
 137
 138   if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
 139     return SCM_FRAME_LOCAL (fp, 0);
 140
 141   return SCM_BOOL_F;
 142 }
 143
 144 SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
 145             (SCM frame),
 146             "")
 147 #define FUNC_NAME s_scm_frame_procedure
 148 {
 149   SCM_VALIDATE_VM_FRAME (1, frame);
 150
 151   /* FIXME: Retrieve procedure from address?  */
 152   return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
 153                               SCM_VM_FRAME_DATA (frame));
 154 }
 155 #undef FUNC_NAME
 156
 157 static SCM frame_arguments_var;
 158
 159 static void
 160 init_frame_arguments_var (void)
 161 {
 162   frame_arguments_var
 163     = scm_c_private_lookup ("system vm frame", "frame-arguments");
 164 }
 165
 166 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
 167             (SCM frame),
 168             "")
 169 #define FUNC_NAME s_scm_frame_arguments
 170 {
 171   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 172   scm_i_pthread_once (&once, init_frame_arguments_var);
 173
 174   SCM_VALIDATE_VM_FRAME (1, frame);
 175
 176   return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
 177 }
 178 #undef FUNC_NAME
 179
 180 static SCM frame_call_representation_var;
 181
 182 static void
 183 init_frame_call_representation_var (void)
 184 {
 185   frame_call_representation_var
 186     = scm_c_private_lookup ("system vm frame", "frame-call-representation");
 187 }
 188
 189 SCM scm_frame_call_representation (SCM frame)
 190 #define FUNC_NAME "frame-call-representation"
 191 {
 192   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 193   scm_i_pthread_once (&once, init_frame_call_representation_var);
 194
 195   SCM_VALIDATE_VM_FRAME (1, frame);
 196
 197   return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
 198 }
 199 #undef FUNC_NAME
 200
 201 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
 202             (SCM frame),
 203             "")
 204 #define FUNC_NAME s_scm_frame_source
 205 {
 206   SCM_VALIDATE_VM_FRAME (1, frame);
 207
 208   return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
 209 }
 210 #undef FUNC_NAME
 211
 212 SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 213             (SCM frame),
 214             "")
 215 #define FUNC_NAME s_scm_frame_num_locals
 216 {
 217   SCM *fp, *sp;
 218
 219   SCM_VALIDATE_VM_FRAME (1, frame);
 220
 221   fp = SCM_VM_FRAME_FP (frame);
 222   sp = SCM_VM_FRAME_SP (frame);
 223
 224   return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
 225 }
 226 #undef FUNC_NAME
 227
 228 SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
 229             (SCM frame, SCM index),
 230             "")
 231 #define FUNC_NAME s_scm_frame_local_ref
 232 {
 233   SCM *fp, *sp;
 234   unsigned int i;
 235
 236   SCM_VALIDATE_VM_FRAME (1, frame);
 237   SCM_VALIDATE_UINT_COPY (2, index, i);
 238
 239   fp = SCM_VM_FRAME_FP (frame);
 240   sp = SCM_VM_FRAME_SP (frame);
 241
 242   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 243     return SCM_FRAME_LOCAL (fp, i);
 244
 245   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 246 }
 247 #undef FUNC_NAME
 248
 249 /* Need same not-yet-active frame logic here as in frame-num-locals */
 250 SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 251             (SCM frame, SCM index, SCM val),
 252             "")
 253 #define FUNC_NAME s_scm_frame_local_set_x
 254 {
 255   SCM *fp, *sp;
 256   unsigned int i;
 257
 258   SCM_VALIDATE_VM_FRAME (1, frame);
 259   SCM_VALIDATE_UINT_COPY (2, index, i);
 260
 261   fp = SCM_VM_FRAME_FP (frame);
 262   sp = SCM_VM_FRAME_SP (frame);
 263
 264   if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
 265     {
 266       SCM_FRAME_LOCAL (fp, i) = val;
 267       return SCM_UNSPECIFIED;
 268     }
 269
 270   SCM_OUT_OF_RANGE (SCM_ARG2, index);
 271 }
 272 #undef FUNC_NAME
 273
 274 SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
 275             (SCM frame),
 276             "Return the frame pointer for @var{frame}.")
 277 #define FUNC_NAME s_scm_frame_address
 278 {
 279   SCM_VALIDATE_VM_FRAME (1, frame);
 280   return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
 281 }
 282 #undef FUNC_NAME
 283
 284 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
 285             (SCM frame),
 286             "")
 287 #define FUNC_NAME s_scm_frame_stack_pointer
 288 {
 289   SCM_VALIDATE_VM_FRAME (1, frame);
 290
 291   return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
 292 }
 293 #undef FUNC_NAME
 294
 295 SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
 296             (SCM frame),
 297             "")
 298 #define FUNC_NAME s_scm_frame_instruction_pointer
 299 {
 300   SCM_VALIDATE_VM_FRAME (1, frame);
 301
 302   return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
 303 }
 304 #undef FUNC_NAME
 305
 306 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 307             (SCM frame),
 308             "")
 309 #define FUNC_NAME s_scm_frame_return_address
 310 {
 311   SCM_VALIDATE_VM_FRAME (1, frame);
 312   return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
 313                                               (SCM_VM_FRAME_FP (frame))));
 314 }
 315 #undef FUNC_NAME
 316
 317 #define RELOC(kind, frame, val)                                 \
 318   (((SCM *) (val)) + frame_offset (kind, frame))
 319
 320 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 321             (SCM frame),
 322             "")
 323 #define FUNC_NAME s_scm_frame_dynamic_link
 324 {
 325   SCM_VALIDATE_VM_FRAME (1, frame);
 326   /* fixme: munge fp if holder is a continuation */
 327   return scm_from_uintptr_t
 328     ((scm_t_uintptr)
 329      RELOC (SCM_VM_FRAME_KIND (frame), SCM_VM_FRAME_DATA (frame),
 330             SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
 331 }
 332 #undef FUNC_NAME
 333
 334 int
 335 scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
 336 {
 337   SCM *this_fp, *new_fp, *new_sp;
 338   SCM *stack_base = frame_stack_base (kind, frame);
 339
 340  again:
 341   this_fp = frame->fp_offset + stack_base;
 342
 343   if (this_fp == stack_base)
 344     return 0;
 345
 346   new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
 347
 348   if (!new_fp)
 349     return 0;
 350
 351   new_fp = RELOC (kind, frame, new_fp);
 352
 353   if (new_fp < stack_base)
 354     return 0;
 355
 356   new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
 357   frame->fp_offset = new_fp - stack_base;
 358   frame->sp_offset = new_sp - stack_base;
 359   frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
 360
 361   {
 362     SCM proc = scm_c_frame_closure (kind, frame);
 363     if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
 364       goto again;
 365   }
 366
 367   return 1;
 368 }
 369
 370 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
 371             (SCM frame),
 372             "")
 373 #define FUNC_NAME s_scm_frame_previous
 374 {
 375   enum scm_vm_frame_kind kind;
 376   struct scm_frame tmp;
 377
 378   SCM_VALIDATE_VM_FRAME (1, frame);
 379
 380   kind = SCM_VM_FRAME_KIND (frame);
 381   memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
 382
 383   if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
 384     return SCM_BOOL_F;
 385
 386   return scm_c_make_frame (kind, &tmp);
 387 }
 388 #undef FUNC_NAME
 389
 390 \f
 391 void
 392 scm_init_frames (void)
 393 {
 394 #ifndef SCM_MAGIC_SNARFER
 395 #include "libguile/frames.x"
 396 #endif
 397 }
 398
 399 /*
 400   Local Variables:
 401   c-file-style: "gnu"
 402   End:
 403 */