1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
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);
38 scm_c_make_frame (enum scm_vm_frame_kind kind
, const struct scm_frame
*frame
)
40 struct scm_frame
*p
= scm_gc_malloc (sizeof (struct scm_frame
),
42 p
->stack_holder
= frame
->stack_holder
;
43 p
->fp_offset
= frame
->fp_offset
;
44 p
->sp_offset
= frame
->sp_offset
;
46 return scm_cell (scm_tc7_frame
| (kind
<< 8), (scm_t_bits
)p
);
50 scm_i_frame_print (SCM frame
, SCM port
, scm_print_state
*pstate
)
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
);
61 frame_stack_base (enum scm_vm_frame_kind kind
, const struct scm_frame
*frame
)
65 case SCM_VM_FRAME_KIND_CONT
:
66 return ((struct scm_vm_cont
*) frame
->stack_holder
)->stack_base
;
68 case SCM_VM_FRAME_KIND_VM
:
69 return ((struct scm_vm
*) frame
->stack_holder
)->stack_base
;
77 frame_offset (enum scm_vm_frame_kind kind
, const struct scm_frame
*frame
)
81 case SCM_VM_FRAME_KIND_CONT
:
82 return ((struct scm_vm_cont
*) frame
->stack_holder
)->reloc
;
84 case SCM_VM_FRAME_KIND_VM
:
93 scm_i_frame_stack_base (SCM frame
)
94 #define FUNC_NAME "frame-stack-base"
96 SCM_VALIDATE_VM_FRAME (1, frame
);
98 return frame_stack_base (SCM_VM_FRAME_KIND (frame
),
99 SCM_VM_FRAME_DATA (frame
));
104 scm_i_frame_offset (SCM frame
)
105 #define FUNC_NAME "frame-offset"
107 SCM_VALIDATE_VM_FRAME (1, frame
);
109 return frame_offset (SCM_VM_FRAME_KIND (frame
),
110 SCM_VM_FRAME_DATA (frame
));
116 /* Scheme interface */
118 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
121 #define FUNC_NAME s_scm_frame_p
123 return scm_from_bool (SCM_VM_FRAME_P (obj
));
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. */
131 scm_c_frame_closure (enum scm_vm_frame_kind kind
, const struct scm_frame
*frame
)
135 fp
= frame_stack_base (kind
, frame
) + frame
->fp_offset
;
136 sp
= frame_stack_base (kind
, frame
) + frame
->sp_offset
;
138 if (SCM_FRAME_NUM_LOCALS (fp
, sp
) > 0)
139 return SCM_FRAME_LOCAL (fp
, 0);
144 SCM_DEFINE (scm_frame_procedure
, "frame-procedure", 1, 0, 0,
147 #define FUNC_NAME s_scm_frame_procedure
149 SCM_VALIDATE_VM_FRAME (1, frame
);
151 /* FIXME: Retrieve procedure from address? */
152 return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame
),
153 SCM_VM_FRAME_DATA (frame
));
157 static SCM frame_arguments_var
;
160 init_frame_arguments_var (void)
163 = scm_c_private_lookup ("system vm frame", "frame-arguments");
166 SCM_DEFINE (scm_frame_arguments
, "frame-arguments", 1, 0, 0,
169 #define FUNC_NAME s_scm_frame_arguments
171 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
172 scm_i_pthread_once (&once
, init_frame_arguments_var
);
174 SCM_VALIDATE_VM_FRAME (1, frame
);
176 return scm_call_1 (scm_variable_ref (frame_arguments_var
), frame
);
180 static SCM frame_call_representation_var
;
183 init_frame_call_representation_var (void)
185 frame_call_representation_var
186 = scm_c_private_lookup ("system vm frame", "frame-call-representation");
189 SCM
scm_frame_call_representation (SCM frame
)
190 #define FUNC_NAME "frame-call-representation"
192 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
193 scm_i_pthread_once (&once
, init_frame_call_representation_var
);
195 SCM_VALIDATE_VM_FRAME (1, frame
);
197 return scm_call_1 (scm_variable_ref (frame_call_representation_var
), frame
);
201 SCM_DEFINE (scm_frame_source
, "frame-source", 1, 0, 0,
204 #define FUNC_NAME s_scm_frame_source
206 SCM_VALIDATE_VM_FRAME (1, frame
);
208 return scm_find_source_for_addr (scm_frame_instruction_pointer (frame
));
212 SCM_DEFINE (scm_frame_num_locals
, "frame-num-locals", 1, 0, 0,
215 #define FUNC_NAME s_scm_frame_num_locals
219 SCM_VALIDATE_VM_FRAME (1, frame
);
221 fp
= SCM_VM_FRAME_FP (frame
);
222 sp
= SCM_VM_FRAME_SP (frame
);
224 return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp
, sp
));
228 SCM_DEFINE (scm_frame_local_ref
, "frame-local-ref", 2, 0, 0,
229 (SCM frame
, SCM index
),
231 #define FUNC_NAME s_scm_frame_local_ref
236 SCM_VALIDATE_VM_FRAME (1, frame
);
237 SCM_VALIDATE_UINT_COPY (2, index
, i
);
239 fp
= SCM_VM_FRAME_FP (frame
);
240 sp
= SCM_VM_FRAME_SP (frame
);
242 if (i
< SCM_FRAME_NUM_LOCALS (fp
, sp
))
243 return SCM_FRAME_LOCAL (fp
, i
);
245 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
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
),
253 #define FUNC_NAME s_scm_frame_local_set_x
258 SCM_VALIDATE_VM_FRAME (1, frame
);
259 SCM_VALIDATE_UINT_COPY (2, index
, i
);
261 fp
= SCM_VM_FRAME_FP (frame
);
262 sp
= SCM_VM_FRAME_SP (frame
);
264 if (i
< SCM_FRAME_NUM_LOCALS (fp
, sp
))
266 SCM_FRAME_LOCAL (fp
, i
) = val
;
267 return SCM_UNSPECIFIED
;
270 SCM_OUT_OF_RANGE (SCM_ARG2
, index
);
274 SCM_DEFINE (scm_frame_address
, "frame-address", 1, 0, 0,
276 "Return the frame pointer for @var{frame}.")
277 #define FUNC_NAME s_scm_frame_address
279 SCM_VALIDATE_VM_FRAME (1, frame
);
280 return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame
));
284 SCM_DEFINE (scm_frame_stack_pointer
, "frame-stack-pointer", 1, 0, 0,
287 #define FUNC_NAME s_scm_frame_stack_pointer
289 SCM_VALIDATE_VM_FRAME (1, frame
);
291 return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame
));
295 SCM_DEFINE (scm_frame_instruction_pointer
, "frame-instruction-pointer", 1, 0, 0,
298 #define FUNC_NAME s_scm_frame_instruction_pointer
300 SCM_VALIDATE_VM_FRAME (1, frame
);
302 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_VM_FRAME_IP (frame
));
306 SCM_DEFINE (scm_frame_return_address
, "frame-return-address", 1, 0, 0,
309 #define FUNC_NAME s_scm_frame_return_address
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
))));
317 #define RELOC(kind, frame, val) \
318 (((SCM *) (val)) + frame_offset (kind, frame))
320 SCM_DEFINE (scm_frame_dynamic_link
, "frame-dynamic-link", 1, 0, 0,
323 #define FUNC_NAME s_scm_frame_dynamic_link
325 SCM_VALIDATE_VM_FRAME (1, frame
);
326 /* fixme: munge fp if holder is a continuation */
327 return scm_from_uintptr_t
329 RELOC (SCM_VM_FRAME_KIND (frame
), SCM_VM_FRAME_DATA (frame
),
330 SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame
))));
335 scm_c_frame_previous (enum scm_vm_frame_kind kind
, struct scm_frame
*frame
)
337 SCM
*this_fp
, *new_fp
, *new_sp
;
338 SCM
*stack_base
= frame_stack_base (kind
, frame
);
341 this_fp
= frame
->fp_offset
+ stack_base
;
343 if (this_fp
== stack_base
)
346 new_fp
= SCM_FRAME_DYNAMIC_LINK (this_fp
);
351 new_fp
= RELOC (kind
, frame
, new_fp
);
353 if (new_fp
< stack_base
)
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
);
362 SCM proc
= scm_c_frame_closure (kind
, frame
);
363 if (SCM_PROGRAM_P (proc
) && SCM_PROGRAM_IS_BOOT (proc
))
370 SCM_DEFINE (scm_frame_previous
, "frame-previous", 1, 0, 0,
373 #define FUNC_NAME s_scm_frame_previous
375 enum scm_vm_frame_kind kind
;
376 struct scm_frame tmp
;
378 SCM_VALIDATE_VM_FRAME (1, frame
);
380 kind
= SCM_VM_FRAME_KIND (frame
);
381 memcpy (&tmp
, SCM_VM_FRAME_DATA (frame
), sizeof tmp
);
383 if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame
), &tmp
))
386 return scm_c_make_frame (kind
, &tmp
);
392 scm_init_frames (void)
394 #ifndef SCM_MAGIC_SNARFER
395 #include "libguile/frames.x"