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_FREE_VARIABLES 1 /* Check free variable access */
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_FREE_VARIABLES 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
*free_vars
= NULL
; /* free variables */
51 size_t free_vars_count
= 0; /* length of FREE_VARS */
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
);
110 PUSH ((SCM
)fp
); /* dynamic link */
117 /* Initial arguments */
119 if (SCM_UNLIKELY (sp
+ nargs
>= stack_limit
))
120 goto vm_error_too_many_args
;
129 #ifndef HAVE_LABELS_AS_VALUES
131 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
134 #include "vm-expand.h"
135 #include "vm-i-system.c"
136 #include "vm-i-scheme.c"
137 #include "vm-i-loader.c"
139 #ifndef HAVE_LABELS_AS_VALUES
141 goto vm_error_bad_instruction
;
148 #if VM_PUSH_DEBUG_FRAMES
149 scm_i_set_last_debug_frame (debug
.prev
);
157 vm_error_bad_instruction
:
158 err_msg
= scm_from_locale_string ("VM: Bad instruction: ~A");
159 finish_args
= scm_list_1 (scm_from_uchar (ip
[-1]));
163 err_msg
= scm_from_locale_string ("VM: Unbound variable: ~A");
166 vm_error_wrong_type_arg
:
167 err_msg
= scm_from_locale_string ("VM: Wrong type argument");
168 finish_args
= SCM_EOL
;
171 vm_error_too_many_args
:
172 err_msg
= scm_from_locale_string ("VM: Too many arguments");
173 finish_args
= scm_list_1 (scm_from_int (nargs
));
176 vm_error_wrong_num_args
:
177 /* nargs and program are valid */
179 scm_wrong_num_args (program
);
180 /* shouldn't get here */
183 vm_error_wrong_type_apply
:
184 err_msg
= scm_from_locale_string ("VM: Wrong type to apply: ~S "
186 finish_args
= scm_list_2 (program
,
187 SCM_I_MAKINUM (ip
- bp
->base
));
190 vm_error_stack_overflow
:
191 err_msg
= scm_from_locale_string ("VM: Stack overflow");
192 finish_args
= SCM_EOL
;
195 vm_error_stack_underflow
:
196 err_msg
= scm_from_locale_string ("VM: Stack underflow");
197 finish_args
= SCM_EOL
;
200 vm_error_improper_list
:
201 err_msg
= scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
206 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "pair");
207 /* shouldn't get here */
210 vm_error_not_a_bytevector
:
212 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "bytevector");
213 /* shouldn't get here */
217 err_msg
= scm_from_locale_string ("VM: 0-valued return");
218 finish_args
= SCM_EOL
;
221 vm_error_not_enough_values
:
222 err_msg
= scm_from_locale_string ("VM: Not enough values for mv-bind");
223 finish_args
= SCM_EOL
;
226 vm_error_bad_wide_string_length
:
227 err_msg
= scm_from_locale_string ("VM: Bad wide string length: ~S");
231 vm_error_invalid_address
:
232 err_msg
= scm_from_locale_string ("VM: Invalid program address");
233 finish_args
= SCM_EOL
;
239 err_msg
= scm_from_locale_string ("VM: Invalid object table access");
240 finish_args
= SCM_EOL
;
244 #if VM_CHECK_FREE_VARIABLES
245 vm_error_free_variable
:
246 err_msg
= scm_from_locale_string ("VM: Invalid free variable access");
247 finish_args
= SCM_EOL
;
254 scm_ithrow (sym_vm_error
, scm_list_3 (sym_vm_run
, err_msg
, finish_args
),
258 abort (); /* never reached */
263 #undef VM_CHECK_OBJECT
264 #undef VM_CHECK_FREE_VARIABLE
265 #undef VM_PUSH_DEBUG_FRAMES