1 /* Copyright (C) 2001, 2009 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
19 /* This file is included in vm.c multiple times */
21 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
22 #define VM_USE_HOOKS 0 /* Various hooks */
23 #define VM_USE_CLOCK 0 /* Bogoclock */
24 #define VM_CHECK_OBJECT 1 /* Check object table */
25 #define VM_CHECK_CLOSURE 1 /* Check closure vars */
26 #define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
27 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
28 #define VM_USE_HOOKS 1
29 #define VM_USE_CLOCK 1
30 #define VM_CHECK_OBJECT 1
31 #define VM_CHECK_CLOSURE 1
32 #define VM_PUSH_DEBUG_FRAMES 1
34 #error unknown debug engine VM_ENGINE
37 #include "vm-engine.h"
41 VM_NAME (struct scm_vm
*vp
, SCM program
, SCM
*argv
, int nargs
)
44 register scm_byte_t
*ip IP_REG
; /* instruction pointer */
45 register SCM
*sp SP_REG
; /* stack pointer */
46 register SCM
*fp FP_REG
; /* frame pointer */
49 struct scm_objcode
*bp
= NULL
; /* program base pointer */
50 SCM
*closure
= NULL
; /* closure variables */
51 size_t closure_count
= 0; /* length of CLOSURE */
52 SCM
*objects
= NULL
; /* constant objects */
53 size_t object_count
= 0; /* length of OBJECTS */
54 SCM
*stack_base
= vp
->stack_base
; /* stack base address */
55 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
57 /* Internal variables */
59 long start_time
= scm_c_get_internal_run_time ();
60 SCM finish_args
; /* used both for returns: both in error
61 and normal situations */
63 SCM hook_args
= SCM_EOL
;
66 #ifdef HAVE_LABELS_AS_VALUES
67 static void **jump_table
= NULL
;
70 #if VM_PUSH_DEBUG_FRAMES
71 scm_t_debug_frame debug
;
72 scm_t_debug_info debug_vect_body
;
73 debug
.status
= SCM_VOIDFRAME
;
76 #ifdef HAVE_LABELS_AS_VALUES
77 if (SCM_UNLIKELY (!jump_table
))
80 jump_table
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof(void*));
81 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
82 jump_table
[i
] = &&vm_error_bad_instruction
;
83 #define VM_INSTRUCTION_TO_LABEL 1
84 #include <libguile/vm-expand.h>
85 #include <libguile/vm-i-system.i>
86 #include <libguile/vm-i-scheme.i>
87 #include <libguile/vm-i-loader.i>
88 #undef VM_INSTRUCTION_TO_LABEL
97 program
= vm_make_boot_program (nargs
);
99 #if VM_PUSH_DEBUG_FRAMES
100 debug
.prev
= scm_i_last_debug_frame ();
101 debug
.status
= SCM_APPLYFRAME
;
102 debug
.vect
= &debug_vect_body
;
103 debug
.vect
[0].a
.proc
= program
; /* the boot program */
104 debug
.vect
[0].a
.args
= SCM_EOL
;
105 scm_i_set_last_debug_frame (&debug
);
114 /* Initial arguments */
116 if (SCM_UNLIKELY (sp
+ nargs
>= stack_limit
))
117 goto vm_error_too_many_args
;
126 #ifndef HAVE_LABELS_AS_VALUES
128 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
131 #include "vm-expand.h"
132 #include "vm-i-system.c"
133 #include "vm-i-scheme.c"
134 #include "vm-i-loader.c"
136 #ifndef HAVE_LABELS_AS_VALUES
138 goto vm_error_bad_instruction
;
145 #if VM_PUSH_DEBUG_FRAMES
146 scm_i_set_last_debug_frame (debug
.prev
);
154 vm_error_bad_instruction
:
155 err_msg
= scm_from_locale_string ("VM: Bad instruction: ~A");
156 finish_args
= scm_list_1 (scm_from_uchar (ip
[-1]));
160 err_msg
= scm_from_locale_string ("VM: Unbound variable: ~A");
163 vm_error_wrong_type_arg
:
164 err_msg
= scm_from_locale_string ("VM: Wrong type argument");
165 finish_args
= SCM_EOL
;
168 vm_error_too_many_args
:
169 err_msg
= scm_from_locale_string ("VM: Too many arguments");
170 finish_args
= scm_list_1 (scm_from_int (nargs
));
173 vm_error_wrong_num_args
:
174 /* nargs and program are valid */
176 scm_wrong_num_args (program
);
177 /* shouldn't get here */
180 vm_error_wrong_type_apply
:
181 err_msg
= scm_from_locale_string ("VM: Wrong type to apply: ~S "
183 finish_args
= scm_list_2 (program
,
184 SCM_I_MAKINUM (ip
- bp
->base
));
187 vm_error_stack_overflow
:
188 err_msg
= scm_from_locale_string ("VM: Stack overflow");
189 finish_args
= SCM_EOL
;
192 vm_error_stack_underflow
:
193 err_msg
= scm_from_locale_string ("VM: Stack underflow");
194 finish_args
= SCM_EOL
;
197 vm_error_improper_list
:
198 err_msg
= scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
203 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "pair");
204 /* shouldn't get here */
207 vm_error_not_a_bytevector
:
209 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "bytevector");
210 /* shouldn't get here */
214 err_msg
= scm_from_locale_string ("VM: 0-valued return");
215 finish_args
= SCM_EOL
;
218 vm_error_not_enough_values
:
219 err_msg
= scm_from_locale_string ("VM: Not enough values for mv-bind");
220 finish_args
= SCM_EOL
;
224 vm_error_invalid_address
:
225 err_msg
= scm_from_locale_string ("VM: Invalid program address");
226 finish_args
= SCM_EOL
;
232 err_msg
= scm_from_locale_string ("VM: Invalid object table access");
233 finish_args
= SCM_EOL
;
239 err_msg
= scm_from_locale_string ("VM: Invalid closure variable access");
240 finish_args
= SCM_EOL
;
247 scm_ithrow (sym_vm_error
, scm_list_3 (sym_vm_run
, err_msg
, finish_args
),
251 abort (); /* never reached */
256 #undef VM_CHECK_OBJECT
257 #undef VM_CHECK_CLOSURE
258 #undef VM_PUSH_DEBUG_FRAMES