1 /* Copyright (C) 2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
45 #include "instructions.h"
50 /* I sometimes use this for debugging. */
51 #define vm_puts(OBJ) \
53 scm_display (OBJ, scm_def_errp); \
54 scm_newline (scm_def_errp); \
62 scm_t_bits scm_tc16_vm_cont
;
65 #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
66 #define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
69 capture_vm_cont (struct scm_vm
*vp
)
71 struct scm_vm
*p
= scm_must_malloc (sizeof (*p
), "capture_vm_cont");
72 p
->stack_size
= vp
->stack_limit
- vp
->sp
;
73 p
->stack_base
= scm_must_malloc (p
->stack_size
* sizeof (SCM
),
75 p
->stack_limit
= p
->stack_base
+ p
->stack_size
- 2;
77 p
->sp
= (SCM
*) (vp
->stack_limit
- vp
->sp
);
78 p
->fp
= (SCM
*) (vp
->stack_limit
- vp
->fp
);
79 memcpy (p
->stack_base
, vp
->sp
+ 1, vp
->stack_size
* sizeof (SCM
));
80 SCM_RETURN_NEWSMOB (scm_tc16_vm_cont
, p
);
84 reinstate_vm_cont (struct scm_vm
*vp
, SCM cont
)
86 struct scm_vm
*p
= SCM_VM_CONT_VP (cont
);
87 if (vp
->stack_size
< p
->stack_size
)
89 /* puts ("FIXME: Need to expand"); */
93 vp
->sp
= vp
->stack_limit
- (int) p
->sp
;
94 vp
->fp
= vp
->stack_limit
- (int) p
->fp
;
95 memcpy (vp
->sp
+ 1, p
->stack_base
, p
->stack_size
* sizeof (SCM
));
99 vm_cont_mark (SCM obj
)
102 struct scm_vm
*vp
= SCM_VM_CONT_VP (obj
);
103 for (p
= vp
->stack_base
; p
<= vp
->stack_limit
; p
++)
110 vm_cont_free (SCM obj
)
112 struct scm_vm
*p
= SCM_VM_CONT_VP (obj
);
113 int size
= sizeof (struct scm_vm
) + p
->stack_size
* sizeof (SCM
);
114 scm_must_free (p
->stack_base
);
121 * VM Internal functions
124 SCM_SYMBOL (sym_vm_run
, "vm-run");
125 SCM_SYMBOL (sym_vm_error
, "vm-error");
128 vm_fetch_length (scm_byte_t
*ip
, size_t *lenp
)
130 /* NOTE: format defined in system/vm/conv.scm */
134 else if (*lenp
== 254)
138 *lenp
= (b1
<< 8) + b2
;
146 *lenp
= (b1
<< 24) + (b2
<< 16) + (b3
<< 8) + b4
;
152 vm_heapify_frames_1 (struct scm_vm
*vp
, SCM
*fp
, SCM
*sp
, SCM
**destp
)
155 SCM
*dl
= SCM_FRAME_DYNAMIC_LINK (fp
);
156 SCM
*src
= SCM_FRAME_UPPER_ADDRESS (fp
);
157 SCM
*dest
= SCM_FRAME_LOWER_ADDRESS (fp
);
162 frame
= scm_c_make_heap_frame (fp
);
163 fp
= SCM_HEAP_FRAME_POINTER (frame
);
164 SCM_FRAME_HEAP_LINK (fp
) = SCM_BOOL_T
;
169 SCM link
= SCM_FRAME_HEAP_LINK (dl
);
170 if (!SCM_FALSEP (link
))
171 link
= SCM_FRAME_LOWER_ADDRESS (dl
)[-1]; /* self link */
173 link
= vm_heapify_frames_1 (vp
, dl
, dest
- 1, &dest
);
174 frame
= scm_c_make_heap_frame (fp
);
175 fp
= SCM_HEAP_FRAME_POINTER (frame
);
176 SCM_FRAME_HEAP_LINK (fp
) = link
;
177 SCM_FRAME_DYNAMIC_LINK (fp
) = SCM_HEAP_FRAME_POINTER (link
);
180 /* Move stack data */
181 for (; src
<= sp
; src
++, dest
++)
189 vm_heapify_frames (SCM vm
)
191 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
192 if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp
->fp
)))
195 vp
->this_frame
= vm_heapify_frames_1 (vp
, vp
->fp
, vp
->sp
, &dest
);
196 vp
->fp
= SCM_HEAP_FRAME_POINTER (vp
->this_frame
);
199 return vp
->this_frame
;
207 #define VM_DEFAULT_STACK_SIZE (16 * 1024)
209 #define VM_REGULAR_ENGINE 0
210 #define VM_DEBUG_ENGINE 1
213 #define VM_NAME vm_regular_engine
214 #define VM_ENGINE VM_REGULAR_ENGINE
215 #include "vm_engine.c"
220 #define VM_NAME vm_debug_engine
221 #define VM_ENGINE VM_DEBUG_ENGINE
222 #include "vm_engine.c"
226 scm_t_bits scm_tc16_vm
;
232 #define FUNC_NAME "make_vm"
235 struct scm_vm
*vp
= SCM_MUST_MALLOC (sizeof (struct scm_vm
));
236 vp
->stack_size
= VM_DEFAULT_STACK_SIZE
;
237 vp
->stack_base
= SCM_MUST_MALLOC (vp
->stack_size
* sizeof (SCM
));
238 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- 3;
240 vp
->sp
= vp
->stack_base
- 1;
244 vp
->options
= SCM_EOL
;
245 vp
->this_frame
= SCM_BOOL_F
;
246 vp
->last_frame
= SCM_BOOL_F
;
247 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
248 vp
->hooks
[i
] = SCM_BOOL_F
;
249 SCM_RETURN_NEWSMOB (scm_tc16_vm
, vp
);
257 struct scm_vm
*vp
= SCM_VM_DATA (obj
);
259 /* mark the stack conservatively */
260 scm_mark_locations ((SCM_STACKITEM
*) vp
->stack_base
,
261 sizeof (SCM
) * (vp
->sp
- vp
->stack_base
+ 1));
263 /* mark other objects */
264 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
265 scm_gc_mark (vp
->hooks
[i
]);
266 scm_gc_mark (vp
->this_frame
);
267 scm_gc_mark (vp
->last_frame
);
274 struct scm_vm
*vp
= SCM_VM_DATA (obj
);
275 int size
= (sizeof (struct scm_vm
) + vp
->stack_size
* sizeof (SCM
));
276 scm_must_free (vp
->stack_base
);
281 SCM_SYMBOL (sym_debug
, "debug");
284 scm_vm_apply (SCM vm
, SCM program
, SCM args
)
285 #define FUNC_NAME "scm_vm_apply"
287 SCM_VALIDATE_PROGRAM (1, program
);
288 return vm_run (vm
, program
, args
);
292 /* Scheme interface */
294 SCM_DEFINE (scm_vm_version
, "vm-version", 0, 0, 0,
297 #define FUNC_NAME s_scm_vm_version
299 return scm_makfrom0str (VERSION
);
303 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
306 #define FUNC_NAME s_scm_the_vm
313 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
316 #define FUNC_NAME s_scm_vm_p
318 return SCM_BOOL (SCM_VM_P (obj
));
322 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
325 #define FUNC_NAME s_scm_make_vm,
331 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
334 #define FUNC_NAME s_scm_vm_ip
336 SCM_VALIDATE_VM (1, vm
);
337 return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm
)->ip
);
341 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
344 #define FUNC_NAME s_scm_vm_sp
346 SCM_VALIDATE_VM (1, vm
);
347 return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm
)->sp
);
351 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
354 #define FUNC_NAME s_scm_vm_fp
356 SCM_VALIDATE_VM (1, vm
);
357 return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm
)->fp
);
361 #define VM_DEFINE_HOOK(n) \
364 SCM_VALIDATE_VM (1, vm); \
365 vp = SCM_VM_DATA (vm); \
366 if (SCM_FALSEP (vp->hooks[n])) \
367 vp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \
368 return vp->hooks[n]; \
371 SCM_DEFINE (scm_vm_boot_hook
, "vm-boot-hook", 1, 0, 0,
374 #define FUNC_NAME s_scm_vm_boot_hook
376 VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK
);
380 SCM_DEFINE (scm_vm_halt_hook
, "vm-halt-hook", 1, 0, 0,
383 #define FUNC_NAME s_scm_vm_halt_hook
385 VM_DEFINE_HOOK (SCM_VM_HALT_HOOK
);
389 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
392 #define FUNC_NAME s_scm_vm_next_hook
394 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
398 SCM_DEFINE (scm_vm_break_hook
, "vm-break-hook", 1, 0, 0,
401 #define FUNC_NAME s_scm_vm_break_hook
403 VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK
);
407 SCM_DEFINE (scm_vm_enter_hook
, "vm-enter-hook", 1, 0, 0,
410 #define FUNC_NAME s_scm_vm_enter_hook
412 VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK
);
416 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
419 #define FUNC_NAME s_scm_vm_apply_hook
421 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
425 SCM_DEFINE (scm_vm_exit_hook
, "vm-exit-hook", 1, 0, 0,
428 #define FUNC_NAME s_scm_vm_exit_hook
430 VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK
);
434 SCM_DEFINE (scm_vm_return_hook
, "vm-return-hook", 1, 0, 0,
437 #define FUNC_NAME s_scm_vm_return_hook
439 VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK
);
443 SCM_DEFINE (scm_vm_option
, "vm-option", 2, 0, 0,
446 #define FUNC_NAME s_scm_vm_option
448 SCM_VALIDATE_VM (1, vm
);
449 return scm_assq_ref (SCM_VM_DATA (vm
)->options
, key
);
453 SCM_DEFINE (scm_set_vm_option_x
, "set-vm-option!", 3, 0, 0,
454 (SCM vm
, SCM key
, SCM val
),
456 #define FUNC_NAME s_scm_set_vm_option_x
458 SCM_VALIDATE_VM (1, vm
);
459 SCM_VM_DATA (vm
)->options
460 = scm_assq_set_x (SCM_VM_DATA (vm
)->options
, key
, val
);
461 return SCM_UNSPECIFIED
;
465 SCM_DEFINE (scm_vm_stats
, "vm-stats", 1, 0, 0,
468 #define FUNC_NAME s_scm_vm_stats
472 SCM_VALIDATE_VM (1, vm
);
474 stats
= scm_make_vector (scm_from_int (2), SCM_UNSPECIFIED
);
475 scm_vector_set_x (stats
, scm_from_int (0),
476 scm_from_ulong (SCM_VM_DATA (vm
)->time
));
477 scm_vector_set_x (stats
, scm_from_int (1),
478 scm_from_ulong (SCM_VM_DATA (vm
)->clock
));
484 #define VM_CHECK_RUNNING(vm) \
485 if (!SCM_VM_DATA (vm)->ip) \
486 SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
488 SCM_DEFINE (scm_vm_this_frame
, "vm-this-frame", 1, 0, 0,
491 #define FUNC_NAME s_scm_vm_this_frame
493 SCM_VALIDATE_VM (1, vm
);
494 return SCM_VM_DATA (vm
)->this_frame
;
498 SCM_DEFINE (scm_vm_last_frame
, "vm-last-frame", 1, 0, 0,
501 #define FUNC_NAME s_scm_vm_last_frame
503 SCM_VALIDATE_VM (1, vm
);
504 return SCM_VM_DATA (vm
)->last_frame
;
508 SCM_DEFINE (scm_vm_fetch_code
, "vm-fetch-code", 1, 0, 0,
511 #define FUNC_NAME s_scm_vm_fetch_code
516 struct scm_instruction
*p
;
518 SCM_VALIDATE_VM (1, vm
);
519 VM_CHECK_RUNNING (vm
);
521 ip
= SCM_VM_DATA (vm
)->ip
;
522 p
= SCM_INSTRUCTION (*ip
);
524 list
= SCM_LIST1 (scm_str2symbol (p
->name
));
525 for (i
= 1; i
<= p
->len
; i
++)
526 list
= scm_cons (SCM_MAKINUM (ip
[i
]), list
);
527 return scm_reverse_x (list
, SCM_EOL
);
531 SCM_DEFINE (scm_vm_fetch_stack
, "vm-fetch-stack", 1, 0, 0,
534 #define FUNC_NAME s_scm_vm_fetch_stack
540 SCM_VALIDATE_VM (1, vm
);
541 VM_CHECK_RUNNING (vm
);
543 vp
= SCM_VM_DATA (vm
);
544 for (sp
= vp
->stack_base
; sp
<= vp
->sp
; sp
++)
545 ls
= scm_cons (*sp
, ls
);
559 scm_init_instructions ();
560 scm_init_objcodes ();
561 scm_init_programs ();
563 scm_tc16_vm_cont
= scm_make_smob_type ("vm-cont", 0);
564 scm_set_smob_mark (scm_tc16_vm_cont
, vm_cont_mark
);
565 scm_set_smob_free (scm_tc16_vm_cont
, vm_cont_free
);
567 scm_tc16_vm
= scm_make_smob_type ("vm", 0);
568 scm_set_smob_mark (scm_tc16_vm
, vm_mark
);
569 scm_set_smob_free (scm_tc16_vm
, vm_free
);
570 scm_set_smob_apply (scm_tc16_vm
, scm_vm_apply
, 1, 0, 1);
572 the_vm
= scm_permanent_object (make_vm ());
574 #ifndef SCM_MAGIC_SNARFER