1 /* Copyright 2001,2009-2015,2018
2 Free Software Foundation, Inc.
3
4 This file is part of Guile.
5
6 Guile is free software: you can redistribute it and/or modify it
7 under the terms of the GNU Lesser General Public License as published
8 by the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 Guile is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
14 License for more details.
15
16 You should have received a copy of the GNU Lesser General Public
17 License along with Guile. If not, see
18 <https://www.gnu.org/licenses/>. */
19
20 #if HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <stdlib.h>
25 #include <string.h>
26
27 #include "boolean.h"
28 #include "eval.h"
29 #include "extensions.h"
30 #include "gsubr.h"
31 #include "instructions.h"
32 #include "modules.h"
33 #include "numbers.h"
34 #include "pairs.h"
35 #include "ports.h"
36 #include "symbols.h"
37 #include "threads.h"
38 #include "variable.h"
39 #include "version.h"
40 #include "vm.h"
41
42 #include "frames.h"
43
44
45 SCM
scm_c_make_frame(enum scm_vm_frame_kind kind,const struct scm_frame * frame)46 scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
47 {
48 struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
49 "vmframe");
50 p->stack_holder = frame->stack_holder;
51 p->fp_offset = frame->fp_offset;
52 p->sp_offset = frame->sp_offset;
53 p->ip = frame->ip;
54 return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
55 }
56
57 void
scm_i_frame_print(SCM frame,SCM port,scm_print_state * pstate)58 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
59 {
60 scm_puts ("#<frame ", port);
61 scm_uintprint (SCM_UNPACK (frame), 16, port);
62 if (scm_module_system_booted_p)
63 {
64 SCM name = scm_frame_procedure_name (frame);
65
66 if (scm_is_true (name))
67 {
68 scm_putc (' ', port);
69 scm_write (name, port);
70 }
71 }
72 /* Don't write args, they can be ridiculously long. */
73 scm_puts (">", port);
74 }
75
76 static union scm_vm_stack_element*
frame_stack_top(enum scm_vm_frame_kind kind,const struct scm_frame * frame)77 frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
78 {
79 switch (kind)
80 {
81 case SCM_VM_FRAME_KIND_CONT:
82 {
83 struct scm_vm_cont *cont = frame->stack_holder;
84 return cont->stack_bottom + cont->stack_size;
85 }
86
87 case SCM_VM_FRAME_KIND_VM:
88 return ((struct scm_vm *) frame->stack_holder)->stack_top;
89
90 default:
91 abort ();
92 }
93 }
94
95 union scm_vm_stack_element*
scm_i_frame_stack_top(SCM frame)96 scm_i_frame_stack_top (SCM frame)
97 #define FUNC_NAME "frame-stack-top"
98 {
99 SCM_VALIDATE_VM_FRAME (1, frame);
100
101 return frame_stack_top (SCM_VM_FRAME_KIND (frame),
102 SCM_VM_FRAME_DATA (frame));
103 }
104 #undef FUNC_NAME
105
106
107 /* Scheme interface */
108
109 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
110 (SCM obj),
111 "")
112 #define FUNC_NAME s_scm_frame_p
113 {
114 return scm_from_bool (SCM_VM_FRAME_P (obj));
115 }
116 #undef FUNC_NAME
117
118 /* Retrieve the local in slot 0, which may or may not actually be a
119 procedure, and may or may not actually be the procedure being
120 applied. If you want the procedure, look it up from the IP. */
121 SCM
scm_c_frame_closure(enum scm_vm_frame_kind kind,const struct scm_frame * frame)122 scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
123 {
124 union scm_vm_stack_element *fp, *sp;
125
126 fp = frame_stack_top (kind, frame) - frame->fp_offset;
127 sp = frame_stack_top (kind, frame) - frame->sp_offset;
128
129 if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
130 return SCM_FRAME_LOCAL (fp, 0);
131
132 return SCM_BOOL_F;
133 }
134
135 static SCM frame_procedure_name_var;
136
137 static void
init_frame_procedure_name_var(void)138 init_frame_procedure_name_var (void)
139 {
140 frame_procedure_name_var
141 = scm_c_private_lookup ("system vm frame", "frame-procedure-name");
142 }
143
144 SCM_DEFINE (scm_frame_procedure_name, "frame-procedure-name", 1, 0, 0,
145 (SCM frame),
146 "")
147 #define FUNC_NAME s_scm_frame_procedure_name
148 {
149 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
150 scm_i_pthread_once (&once, init_frame_procedure_name_var);
151
152 SCM_VALIDATE_VM_FRAME (1, frame);
153
154 return scm_call_1 (scm_variable_ref (frame_procedure_name_var), frame);
155 }
156 #undef FUNC_NAME
157
158 static SCM frame_arguments_var;
159
160 static void
init_frame_arguments_var(void)161 init_frame_arguments_var (void)
162 {
163 frame_arguments_var
164 = scm_c_private_lookup ("system vm frame", "frame-arguments");
165 }
166
167 SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
168 (SCM frame),
169 "")
170 #define FUNC_NAME s_scm_frame_arguments
171 {
172 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
173 scm_i_pthread_once (&once, init_frame_arguments_var);
174
175 SCM_VALIDATE_VM_FRAME (1, frame);
176
177 return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
178 }
179 #undef FUNC_NAME
180
181 static SCM frame_call_representation_var;
182
183 static void
init_frame_call_representation_var(void)184 init_frame_call_representation_var (void)
185 {
186 frame_call_representation_var
187 = scm_c_private_lookup ("system vm frame", "frame-call-representation");
188 }
189
scm_frame_call_representation(SCM frame)190 SCM scm_frame_call_representation (SCM frame)
191 #define FUNC_NAME "frame-call-representation"
192 {
193 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
194 scm_i_pthread_once (&once, init_frame_call_representation_var);
195
196 SCM_VALIDATE_VM_FRAME (1, frame);
197
198 return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
199 }
200 #undef FUNC_NAME
201
202 SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
203 (SCM frame),
204 "")
205 #define FUNC_NAME s_scm_frame_source
206 {
207 SCM_VALIDATE_VM_FRAME (1, frame);
208
209 return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
210 }
211 #undef FUNC_NAME
212
213 static const char s_scm_frame_num_locals[] = "frame-num-locals";
214 static SCM
scm_frame_num_locals(SCM frame)215 scm_frame_num_locals (SCM frame)
216 #define FUNC_NAME s_scm_frame_num_locals
217 {
218 union scm_vm_stack_element *fp, *sp;
219
220 SCM_VALIDATE_VM_FRAME (1, frame);
221
222 fp = SCM_VM_FRAME_FP (frame);
223 sp = SCM_VM_FRAME_SP (frame);
224
225 return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
226 }
227 #undef FUNC_NAME
228
229 enum stack_item_representation
230 {
231 STACK_ITEM_SCM = 0,
232 STACK_ITEM_F64 = 1,
233 STACK_ITEM_U64 = 2,
234 STACK_ITEM_S64 = 3
235 };
236
237 static enum stack_item_representation
scm_to_stack_item_representation(SCM x,const char * subr,int pos)238 scm_to_stack_item_representation (SCM x, const char *subr, int pos)
239 {
240 if (scm_is_eq (x, scm_from_latin1_symbol ("scm")))
241 return STACK_ITEM_SCM;
242 if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
243 return STACK_ITEM_F64;
244 if (scm_is_eq (x, scm_from_latin1_symbol ("u64")))
245 return STACK_ITEM_U64;
246 if (scm_is_eq (x, scm_from_latin1_symbol ("s64")))
247 return STACK_ITEM_S64;
248
249 scm_wrong_type_arg (subr, pos, x);
250 return 0; /* Not reached. */
251 }
252
253 static const char s_scm_frame_local_ref[] = "frame-local-ref";
254 static SCM
scm_frame_local_ref(SCM frame,SCM index,SCM representation)255 scm_frame_local_ref (SCM frame, SCM index, SCM representation)
256 #define FUNC_NAME s_scm_frame_local_ref
257 {
258 union scm_vm_stack_element *fp, *sp;
259 unsigned int i;
260 enum stack_item_representation repr;
261
262 SCM_VALIDATE_VM_FRAME (1, frame);
263 SCM_VALIDATE_UINT_COPY (2, index, i);
264 repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
265
266 fp = SCM_VM_FRAME_FP (frame);
267 sp = SCM_VM_FRAME_SP (frame);
268
269 if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
270 {
271 union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
272 switch (repr)
273 {
274 case STACK_ITEM_SCM:
275 return item->as_scm;
276 case STACK_ITEM_F64:
277 return scm_from_double (item->as_f64);
278 case STACK_ITEM_U64:
279 return scm_from_uint64 (item->as_u64);
280 case STACK_ITEM_S64:
281 return scm_from_int64 (item->as_s64);
282 default:
283 abort();
284 }
285 }
286
287 SCM_OUT_OF_RANGE (SCM_ARG2, index);
288 }
289 #undef FUNC_NAME
290
291 static const char s_scm_frame_local_set_x[] = "frame-local-set!";
292 static SCM
scm_frame_local_set_x(SCM frame,SCM index,SCM val,SCM representation)293 scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation)
294 #define FUNC_NAME s_scm_frame_local_set_x
295 {
296 union scm_vm_stack_element *fp, *sp;
297 unsigned int i;
298 enum stack_item_representation repr;
299
300 SCM_VALIDATE_VM_FRAME (1, frame);
301 SCM_VALIDATE_UINT_COPY (2, index, i);
302 repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
303
304 fp = SCM_VM_FRAME_FP (frame);
305 sp = SCM_VM_FRAME_SP (frame);
306
307 if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
308 {
309 union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
310 switch (repr)
311 {
312 case STACK_ITEM_SCM:
313 item->as_scm = val;
314 break;
315 case STACK_ITEM_F64:
316 item->as_f64 = scm_to_double (val);
317 break;
318 case STACK_ITEM_U64:
319 item->as_u64 = scm_to_uint64 (val);
320 break;
321 case STACK_ITEM_S64:
322 item->as_s64 = scm_to_int64 (val);
323 break;
324 default:
325 abort();
326 }
327 return SCM_UNSPECIFIED;
328 }
329
330 SCM_OUT_OF_RANGE (SCM_ARG2, index);
331 }
332 #undef FUNC_NAME
333
334 static const char s_scm_frame_return_values[] = "frame-return-values";
335 static SCM
scm_frame_return_values(SCM frame)336 scm_frame_return_values (SCM frame)
337 #define FUNC_NAME s_scm_frame_return_values
338 {
339 const uint32_t *ip;
340 union scm_vm_stack_element *fp, *sp;
341 SCM vals = SCM_EOL;
342 size_t n;
343
344 SCM_VALIDATE_VM_FRAME (1, frame);
345
346 ip = SCM_VM_FRAME_IP (frame);
347 fp = SCM_VM_FRAME_FP (frame);
348 sp = SCM_VM_FRAME_SP (frame);
349
350 if ((*ip & 0xff) != scm_op_return_values)
351 scm_wrong_type_arg_msg (FUNC_NAME, 1, frame, "not a return frame");
352
353 n = SCM_FRAME_NUM_LOCALS (fp, sp);
354 while (n--)
355 vals = scm_cons (SCM_FRAME_LOCAL (fp, n), vals);
356
357 return vals;
358 }
359 #undef FUNC_NAME
360
361 SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
362 (SCM frame),
363 "Return the frame pointer for @var{frame}.")
364 #define FUNC_NAME s_scm_frame_address
365 {
366 SCM_VALIDATE_VM_FRAME (1, frame);
367 return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
368 }
369 #undef FUNC_NAME
370
371 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
372 (SCM frame),
373 "")
374 #define FUNC_NAME s_scm_frame_stack_pointer
375 {
376 SCM_VALIDATE_VM_FRAME (1, frame);
377
378 return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
379 }
380 #undef FUNC_NAME
381
382 SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
383 (SCM frame),
384 "")
385 #define FUNC_NAME s_scm_frame_instruction_pointer
386 {
387 SCM_VALIDATE_VM_FRAME (1, frame);
388
389 return scm_from_uintptr_t ((uintptr_t) SCM_VM_FRAME_IP (frame));
390 }
391 #undef FUNC_NAME
392
393 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
394 (SCM frame),
395 "")
396 #define FUNC_NAME s_scm_frame_return_address
397 {
398 SCM_VALIDATE_VM_FRAME (1, frame);
399 return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_VIRTUAL_RETURN_ADDRESS
400 (SCM_VM_FRAME_FP (frame))));
401 }
402 #undef FUNC_NAME
403
404 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
405 (SCM frame),
406 "")
407 #define FUNC_NAME s_scm_frame_dynamic_link
408 {
409 SCM_VALIDATE_VM_FRAME (1, frame);
410 /* fixme: munge fp if holder is a continuation */
411 return scm_from_uintptr_t
412 ((uintptr_t)
413 SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)));
414 }
415 #undef FUNC_NAME
416
417 int
scm_c_frame_previous(enum scm_vm_frame_kind kind,struct scm_frame * frame)418 scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
419 {
420 union scm_vm_stack_element *this_fp, *new_fp, *new_sp;
421 union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame);
422
423 again:
424 this_fp = stack_top - frame->fp_offset;
425
426 if (this_fp == stack_top)
427 return 0;
428
429 new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
430
431 if (new_fp >= stack_top)
432 return 0;
433
434 new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
435 frame->fp_offset = stack_top - new_fp;
436 frame->sp_offset = stack_top - new_sp;
437 frame->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (this_fp);
438
439 if (scm_i_vm_is_boot_continuation_code (frame->ip))
440 goto again;
441
442 return 1;
443 }
444
445 SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
446 (SCM frame),
447 "")
448 #define FUNC_NAME s_scm_frame_previous
449 {
450 enum scm_vm_frame_kind kind;
451 struct scm_frame tmp;
452
453 SCM_VALIDATE_VM_FRAME (1, frame);
454
455 kind = SCM_VM_FRAME_KIND (frame);
456 memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
457
458 if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
459 return SCM_BOOL_F;
460
461 return scm_c_make_frame (kind, &tmp);
462 }
463 #undef FUNC_NAME
464
465
466 static void
scm_init_frames_builtins(void * unused)467 scm_init_frames_builtins (void *unused)
468 {
469 scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0,
470 (scm_t_subr) scm_frame_num_locals);
471 scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0,
472 (scm_t_subr) scm_frame_local_ref);
473 scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0,
474 (scm_t_subr) scm_frame_local_set_x);
475 scm_c_define_gsubr (s_scm_frame_return_values, 1, 0, 0,
476 (scm_t_subr) scm_frame_return_values);
477 }
478
479 void
scm_init_frames(void)480 scm_init_frames (void)
481 {
482 #ifndef SCM_MAGIC_SNARFER
483 #include "frames.x"
484 #endif
485
486 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
487 "scm_init_frames_builtins",
488 scm_init_frames_builtins,
489 NULL);
490 }
491