1 /* Copyright (C) 2001, 2009, 2010, 2011 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_CHECK_OBJECT 0 /* Check object table */
24 #define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */
25 #define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
26 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
27 #define VM_USE_HOOKS 1
28 #define VM_CHECK_OBJECT 0
29 #define VM_CHECK_FREE_VARIABLES 0
30 #define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
32 #error unknown debug engine VM_ENGINE
35 #include "vm-engine.h"
39 VM_NAME (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
42 register scm_t_uint8
*ip IP_REG
; /* instruction pointer */
43 register SCM
*sp SP_REG
; /* stack pointer */
44 register SCM
*fp FP_REG
; /* frame pointer */
45 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
48 struct scm_objcode
*bp
= NULL
; /* program base pointer */
49 SCM
*objects
= NULL
; /* constant objects */
51 size_t object_count
= 0; /* length of OBJECTS */
53 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
55 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
56 scm_t_int64 vm_cookie
= vp
->cookie
++;
58 /* Internal variables */
60 const char *func_name
= NULL
; /* used for error reporting */
61 SCM finish_args
; /* used both for returns: both in error
62 and normal situations */
63 #ifdef HAVE_LABELS_AS_VALUES
64 static const void **jump_table_pointer
= NULL
;
67 #ifdef HAVE_LABELS_AS_VALUES
68 register const void **jump_table JT_REG
;
70 if (SCM_UNLIKELY (!jump_table_pointer
))
73 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
74 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
75 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
76 #define VM_INSTRUCTION_TO_LABEL 1
77 #define jump_table jump_table_pointer
78 #include <libguile/vm-expand.h>
79 #include <libguile/vm-i-system.i>
80 #include <libguile/vm-i-scheme.i>
81 #include <libguile/vm-i-loader.i>
83 #undef VM_INSTRUCTION_TO_LABEL
86 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
87 load instruction at each instruction dispatch. */
88 jump_table
= jump_table_pointer
;
96 program
= vm_make_boot_program (nargs
);
100 PUSH (SCM_PACK (fp
)); /* dynamic link */
101 PUSH (SCM_PACK (0)); /* mvra */
102 PUSH (SCM_PACK (ip
)); /* ra */
106 ip
= SCM_C_OBJCODE_BASE (bp
);
107 /* MV-call frame, function & arguments */
108 PUSH (SCM_PACK (0)); /* dynamic link */
109 PUSH (SCM_PACK (0)); /* mvra */
110 PUSH (SCM_PACK (0)); /* ra */
112 if (SCM_UNLIKELY (sp
+ nargs
>= stack_limit
))
113 goto vm_error_too_many_args
;
121 #ifndef HAVE_LABELS_AS_VALUES
123 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
126 #include "vm-expand.h"
127 #include "vm-i-system.c"
128 #include "vm-i-scheme.c"
129 #include "vm-i-loader.c"
131 #ifndef HAVE_LABELS_AS_VALUES
133 goto vm_error_bad_instruction
;
146 /* FIXME: need to sync regs before allocating anything, in each case. */
148 vm_error_bad_instruction
:
149 err_msg
= scm_from_latin1_string ("VM: Bad instruction: ~s");
150 finish_args
= scm_list_1 (scm_from_uchar (ip
[-1]));
154 /* FINISH_ARGS should be the name of the unbound variable. */
156 err_msg
= scm_from_latin1_string ("Unbound variable: ~s");
157 scm_error_scm (scm_misc_error_key
, program
, err_msg
,
158 scm_list_1 (finish_args
), SCM_BOOL_F
);
161 vm_error_unbound_fluid
:
163 err_msg
= scm_from_latin1_string ("Unbound fluid: ~s");
164 scm_error_scm (scm_misc_error_key
, program
, err_msg
,
165 scm_list_1 (finish_args
), SCM_BOOL_F
);
168 vm_error_not_a_variable
:
170 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
171 scm_list_1 (finish_args
), scm_list_1 (finish_args
));
174 vm_error_apply_to_non_list
:
176 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
177 scm_list_1 (finish_args
), scm_list_1 (finish_args
));
180 vm_error_kwargs_length_not_even
:
182 err_msg
= scm_from_latin1_string ("Odd length of keyword argument list");
183 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
184 SCM_EOL
, SCM_BOOL_F
);
186 vm_error_kwargs_invalid_keyword
:
187 /* FIXME say which one it was */
189 err_msg
= scm_from_latin1_string ("Invalid keyword");
190 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
191 SCM_EOL
, SCM_BOOL_F
);
193 vm_error_kwargs_unrecognized_keyword
:
194 /* FIXME say which one it was */
196 err_msg
= scm_from_latin1_string ("Unrecognized keyword");
197 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
198 SCM_EOL
, SCM_BOOL_F
);
200 vm_error_too_many_args
:
201 err_msg
= scm_from_latin1_string ("VM: Too many arguments");
202 finish_args
= scm_list_1 (scm_from_int (nargs
));
205 vm_error_wrong_num_args
:
206 /* nargs and program are valid */
208 scm_wrong_num_args (program
);
209 /* shouldn't get here */
212 vm_error_wrong_type_apply
:
214 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
215 scm_list_1 (program
), scm_list_1 (program
));
218 vm_error_stack_overflow
:
219 err_msg
= scm_from_latin1_string ("VM: Stack overflow");
220 finish_args
= SCM_EOL
;
221 if (stack_limit
< vp
->stack_base
+ vp
->stack_size
)
222 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
223 that `throw' below can run on this VM. */
224 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
227 vm_error_stack_underflow
:
228 err_msg
= scm_from_latin1_string ("VM: Stack underflow");
229 finish_args
= SCM_EOL
;
232 vm_error_improper_list
:
233 err_msg
= scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
238 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "pair");
239 /* shouldn't get here */
242 vm_error_not_a_bytevector
:
244 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "bytevector");
245 /* shouldn't get here */
248 vm_error_not_a_struct
:
250 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "struct");
251 /* shouldn't get here */
254 vm_error_not_a_thunk
:
256 scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args
, "thunk");
257 /* shouldn't get here */
261 err_msg
= scm_from_latin1_string ("Zero values returned to single-valued continuation");
262 finish_args
= SCM_EOL
;
265 vm_error_not_enough_values
:
266 err_msg
= scm_from_latin1_string ("Too few values returned to continuation");
267 finish_args
= SCM_EOL
;
270 vm_error_continuation_not_rewindable
:
271 err_msg
= scm_from_latin1_string ("Unrewindable partial continuation");
272 finish_args
= scm_cons (finish_args
, SCM_EOL
);
275 vm_error_bad_wide_string_length
:
276 err_msg
= scm_from_latin1_string ("VM: Bad wide string length: ~S");
280 vm_error_invalid_address
:
281 err_msg
= scm_from_latin1_string ("VM: Invalid program address");
282 finish_args
= SCM_EOL
;
288 err_msg
= scm_from_latin1_string ("VM: Invalid object table access");
289 finish_args
= SCM_EOL
;
293 #if VM_CHECK_FREE_VARIABLES
294 vm_error_free_variable
:
295 err_msg
= scm_from_latin1_string ("VM: Invalid free variable access");
296 finish_args
= SCM_EOL
;
303 scm_ithrow (sym_vm_error
, scm_list_3 (sym_vm_run
, err_msg
, finish_args
),
307 abort (); /* never reached */
311 #undef VM_CHECK_OBJECT
312 #undef VM_CHECK_FREE_VARIABLE
313 #undef VM_CHECK_UNDERFLOW