1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 */
61 #ifdef HAVE_LABELS_AS_VALUES
62 static const void **jump_table_pointer
= NULL
;
65 #ifdef HAVE_LABELS_AS_VALUES
66 register const void **jump_table JT_REG
;
68 if (SCM_UNLIKELY (!jump_table_pointer
))
71 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
72 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
73 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
74 #define VM_INSTRUCTION_TO_LABEL 1
75 #define jump_table jump_table_pointer
76 #include <libguile/vm-expand.h>
77 #include <libguile/vm-i-system.i>
78 #include <libguile/vm-i-scheme.i>
79 #include <libguile/vm-i-loader.i>
81 #undef VM_INSTRUCTION_TO_LABEL
84 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
85 load instruction at each instruction dispatch. */
86 jump_table
= jump_table_pointer
;
91 PUSH (SCM_PACK (fp
)); /* dynamic link */
92 PUSH (SCM_PACK (0)); /* mvra */
93 PUSH (SCM_PACK (ip
)); /* ra */
94 PUSH (boot_continuation
);
96 ip
= SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation
));
98 /* MV-call frame, function & arguments */
99 PUSH (SCM_PACK (fp
)); /* dynamic link */
100 PUSH (SCM_PACK (ip
+ 1)); /* mvra */
101 PUSH (SCM_PACK (ip
)); /* ra */
104 VM_ASSERT (sp
+ nargs
< stack_limit
, vm_error_too_many_args (nargs
));
108 PUSH_CONTINUATION_HOOK ();
112 if (!SCM_PROGRAM_P (program
))
114 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
115 fp
[-1] = SCM_STRUCT_PROCEDURE (program
);
116 else if (SCM_NIMP (program
) && SCM_TYP7 (program
) == scm_tc7_smob
117 && SCM_SMOB_APPLICABLE_P (program
))
119 /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
122 for (i
= sp
- fp
; i
>= 0; i
--)
124 fp
[-1] = SCM_SMOB_DESCRIPTOR (program
).apply_trampoline_objcode
;
129 vm_error_wrong_type_apply (program
);
135 ip
= SCM_C_OBJCODE_BASE (bp
);
142 #ifndef HAVE_LABELS_AS_VALUES
144 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
147 #include "vm-expand.h"
148 #include "vm-i-system.c"
149 #include "vm-i-scheme.c"
150 #include "vm-i-loader.c"
152 #ifndef HAVE_LABELS_AS_VALUES
154 goto vm_error_bad_instruction
;
158 abort (); /* never reached */
160 vm_error_bad_instruction
:
161 vm_error_bad_instruction (ip
[-1]);
162 abort (); /* never reached */
166 vm_error_stack_overflow (vp
);
167 abort (); /* never reached */
171 #undef VM_CHECK_OBJECT
172 #undef VM_CHECK_FREE_VARIABLE
173 #undef VM_CHECK_UNDERFLOW