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_t_uint8
*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_limit
= vp
->stack_limit
; /* stack limit address */
56 /* Internal variables */
58 long start_time
= scm_c_get_internal_run_time ();
59 SCM finish_args
; /* used both for returns: both in error
60 and normal situations */
62 SCM hook_args
= SCM_EOL
;
65 #ifdef HAVE_LABELS_AS_VALUES
66 static void **jump_table
= NULL
;
69 #if VM_PUSH_DEBUG_FRAMES
70 scm_t_debug_frame debug
;
71 scm_t_debug_info debug_vect_body
;
72 debug
.status
= SCM_VOIDFRAME
;
75 #ifdef HAVE_LABELS_AS_VALUES
76 if (SCM_UNLIKELY (!jump_table
))
79 jump_table
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof(void*));
80 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
81 jump_table
[i
] = &&vm_error_bad_instruction
;
82 #define VM_INSTRUCTION_TO_LABEL 1
83 #include <libguile/vm-expand.h>
84 #include <libguile/vm-i-system.i>
85 #include <libguile/vm-i-scheme.i>
86 #include <libguile/vm-i-loader.i>
87 #undef VM_INSTRUCTION_TO_LABEL
96 program
= vm_make_boot_program (nargs
);
98 #if VM_PUSH_DEBUG_FRAMES
99 debug
.prev
= scm_i_last_debug_frame ();
100 debug
.status
= SCM_APPLYFRAME
;
101 debug
.vect
= &debug_vect_body
;
102 debug
.vect
[0].a
.proc
= program
; /* the boot program */
103 debug
.vect
[0].a
.args
= SCM_EOL
;
104 scm_i_set_last_debug_frame (&debug
);
109 PUSH ((SCM
)fp
); /* dynamic link */
111 PUSH ((SCM
)ip
); /* ra */
116 /* MV-call frame, function & arguments */
117 PUSH ((SCM
)fp
); /* dynamic link */
121 if (SCM_UNLIKELY (sp
+ nargs
>= stack_limit
))
122 goto vm_error_too_many_args
;
131 #ifndef HAVE_LABELS_AS_VALUES
133 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
136 #include "vm-expand.h"
137 #include "vm-i-system.c"
138 #include "vm-i-scheme.c"
139 #include "vm-i-loader.c"
141 #ifndef HAVE_LABELS_AS_VALUES
143 goto vm_error_bad_instruction
;
150 #if VM_PUSH_DEBUG_FRAMES
151 scm_i_set_last_debug_frame (debug
.prev
);
159 vm_error_bad_instruction
:
160 err_msg
= scm_from_locale_string ("VM: Bad instruction: ~s");
161 finish_args
= scm_list_1 (scm_from_uchar (ip
[-1]));
165 err_msg
= scm_from_locale_string ("VM: Unbound variable: ~s");
168 vm_error_wrong_type_arg
:
169 err_msg
= scm_from_locale_string ("VM: Wrong type argument");
170 finish_args
= SCM_EOL
;
173 vm_error_too_many_args
:
174 err_msg
= scm_from_locale_string ("VM: Too many arguments");
175 finish_args
= scm_list_1 (scm_from_int (nargs
));
178 vm_error_wrong_num_args
:
179 /* nargs and program are valid */
181 scm_wrong_num_args (program
);
182 /* shouldn't get here */
185 vm_error_wrong_type_apply
:
187 scm_error (scm_misc_error_key
, FUNC_NAME
, "Wrong type to apply: ~S",
188 scm_list_1 (program
), SCM_BOOL_F
);
191 vm_error_stack_overflow
:
192 err_msg
= scm_from_locale_string ("VM: Stack overflow");
193 finish_args
= SCM_EOL
;
196 vm_error_stack_underflow
:
197 err_msg
= scm_from_locale_string ("VM: Stack underflow");
198 finish_args
= SCM_EOL
;
201 vm_error_improper_list
:
202 err_msg
= scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
207 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "pair");
208 /* shouldn't get here */
211 vm_error_not_a_bytevector
:
213 scm_wrong_type_arg_msg (FUNC_NAME
, 1, finish_args
, "bytevector");
214 /* shouldn't get here */
218 err_msg
= scm_from_locale_string ("Zero values returned to single-valued continuation");
219 finish_args
= SCM_EOL
;
222 vm_error_not_enough_values
:
223 err_msg
= scm_from_locale_string ("Too few values returned to continuation");
224 finish_args
= SCM_EOL
;
227 vm_error_bad_wide_string_length
:
228 err_msg
= scm_from_locale_string ("VM: Bad wide string length: ~S");
232 vm_error_invalid_address
:
233 err_msg
= scm_from_locale_string ("VM: Invalid program address");
234 finish_args
= SCM_EOL
;
240 err_msg
= scm_from_locale_string ("VM: Invalid object table access");
241 finish_args
= SCM_EOL
;
245 #if VM_CHECK_FREE_VARIABLES
246 vm_error_free_variable
:
247 err_msg
= scm_from_locale_string ("VM: Invalid free variable access");
248 finish_args
= SCM_EOL
;
255 scm_ithrow (sym_vm_error
, scm_list_3 (sym_vm_run
, err_msg
, finish_args
),
259 abort (); /* never reached */
264 #undef VM_CHECK_OBJECT
265 #undef VM_CHECK_FREE_VARIABLE
266 #undef VM_PUSH_DEBUG_FRAMES