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 void **jump_table
= NULL
;
67 #ifdef HAVE_LABELS_AS_VALUES
68 if (SCM_UNLIKELY (!jump_table
))
71 jump_table
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof(void*));
72 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
73 jump_table
[i
] = &&vm_error_bad_instruction
;
74 #define VM_INSTRUCTION_TO_LABEL 1
75 #include <libguile/vm-expand.h>
76 #include <libguile/vm-i-system.i>
77 #include <libguile/vm-i-scheme.i>
78 #include <libguile/vm-i-loader.i>
79 #undef VM_INSTRUCTION_TO_LABEL
88 program
= vm_make_boot_program (nargs
);
92 PUSH (SCM_PACK (fp
)); /* dynamic link */
93 PUSH (SCM_PACK (0)); /* mvra */
94 PUSH (SCM_PACK (ip
)); /* ra */
98 ip
= SCM_C_OBJCODE_BASE (bp
);
99 /* MV-call frame, function & arguments */
100 PUSH (SCM_PACK (0)); /* dynamic link */
101 PUSH (SCM_PACK (0)); /* mvra */
102 PUSH (SCM_PACK (0)); /* ra */
104 if (SCM_UNLIKELY (sp
+ nargs
>= stack_limit
))
105 goto vm_error_too_many_args
;
113 #ifndef HAVE_LABELS_AS_VALUES
115 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
118 #include "vm-expand.h"
119 #include "vm-i-system.c"
120 #include "vm-i-scheme.c"
121 #include "vm-i-loader.c"
123 #ifndef HAVE_LABELS_AS_VALUES
125 goto vm_error_bad_instruction
;
138 /* FIXME: need to sync regs before allocating anything, in each case. */
140 vm_error_bad_instruction
:
141 err_msg
= scm_from_latin1_string ("VM: Bad instruction: ~s");
142 finish_args
= scm_list_1 (scm_from_uchar (ip
[-1]));
146 /* FINISH_ARGS should be the name of the unbound variable. */
148 err_msg
= scm_from_latin1_string ("Unbound variable: ~s");
149 scm_error_scm (scm_misc_error_key
, program
, err_msg
,
150 scm_list_1 (finish_args
), SCM_BOOL_F
);
153 vm_error_unbound_fluid
:
155 err_msg
= scm_from_latin1_string ("Unbound fluid: ~s");
156 scm_error_scm (scm_misc_error_key
, program
, err_msg
,
157 scm_list_1 (finish_args
), SCM_BOOL_F
);
160 vm_error_not_a_variable
:
162 scm_error (scm_arg_type_key
, func_name
, "Not a variable: ~S",
163 scm_list_1 (finish_args
), scm_list_1 (finish_args
));
166 vm_error_apply_to_non_list
:
168 scm_error (scm_arg_type_key
, "apply", "Apply to non-list: ~S",
169 scm_list_1 (finish_args
), scm_list_1 (finish_args
));
172 vm_error_kwargs_length_not_even
:
174 err_msg
= scm_from_latin1_string ("Odd length of keyword argument list");
175 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
176 SCM_EOL
, SCM_BOOL_F
);
178 vm_error_kwargs_invalid_keyword
:
179 /* FIXME say which one it was */
181 err_msg
= scm_from_latin1_string ("Invalid keyword");
182 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
183 SCM_EOL
, SCM_BOOL_F
);
185 vm_error_kwargs_unrecognized_keyword
:
186 /* FIXME say which one it was */
188 err_msg
= scm_from_latin1_string ("Unrecognized keyword");
189 scm_error_scm (sym_keyword_argument_error
, program
, err_msg
,
190 SCM_EOL
, SCM_BOOL_F
);
192 vm_error_too_many_args
:
193 err_msg
= scm_from_latin1_string ("VM: Too many arguments");
194 finish_args
= scm_list_1 (scm_from_int (nargs
));
197 vm_error_wrong_num_args
:
198 /* nargs and program are valid */
200 scm_wrong_num_args (program
);
201 /* shouldn't get here */
204 vm_error_wrong_type_apply
:
206 scm_error (scm_arg_type_key
, NULL
, "Wrong type to apply: ~S",
207 scm_list_1 (program
), scm_list_1 (program
));
210 vm_error_stack_overflow
:
211 err_msg
= scm_from_latin1_string ("VM: Stack overflow");
212 finish_args
= SCM_EOL
;
213 if (stack_limit
< vp
->stack_base
+ vp
->stack_size
)
214 /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
215 that `throw' below can run on this VM. */
216 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
;
219 vm_error_stack_underflow
:
220 err_msg
= scm_from_latin1_string ("VM: Stack underflow");
221 finish_args
= SCM_EOL
;
224 vm_error_improper_list
:
225 err_msg
= scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
230 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "pair");
231 /* shouldn't get here */
234 vm_error_not_a_bytevector
:
236 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "bytevector");
237 /* shouldn't get here */
240 vm_error_not_a_struct
:
242 scm_wrong_type_arg_msg (func_name
, 1, finish_args
, "struct");
243 /* shouldn't get here */
246 vm_error_not_a_thunk
:
248 scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args
, "thunk");
249 /* shouldn't get here */
253 err_msg
= scm_from_latin1_string ("Zero values returned to single-valued continuation");
254 finish_args
= SCM_EOL
;
257 vm_error_not_enough_values
:
258 err_msg
= scm_from_latin1_string ("Too few values returned to continuation");
259 finish_args
= SCM_EOL
;
262 vm_error_continuation_not_rewindable
:
263 err_msg
= scm_from_latin1_string ("Unrewindable partial continuation");
264 finish_args
= scm_cons (finish_args
, SCM_EOL
);
267 vm_error_bad_wide_string_length
:
268 err_msg
= scm_from_latin1_string ("VM: Bad wide string length: ~S");
272 vm_error_invalid_address
:
273 err_msg
= scm_from_latin1_string ("VM: Invalid program address");
274 finish_args
= SCM_EOL
;
280 err_msg
= scm_from_latin1_string ("VM: Invalid object table access");
281 finish_args
= SCM_EOL
;
285 #if VM_CHECK_FREE_VARIABLES
286 vm_error_free_variable
:
287 err_msg
= scm_from_latin1_string ("VM: Invalid free variable access");
288 finish_args
= SCM_EOL
;
295 scm_ithrow (sym_vm_error
, scm_list_3 (sym_vm_run
, err_msg
, finish_args
),
299 abort (); /* never reached */
303 #undef VM_CHECK_OBJECT
304 #undef VM_CHECK_FREE_VARIABLE
305 #undef VM_CHECK_UNDERFLOW