Commit | Line | Data |
---|---|---|
27c7c630 | 1 | /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
a98cef7e | 2 | * |
560b9c25 | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
a98cef7e | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
560b9c25 AW |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
a98cef7e | 12 | * |
560b9c25 AW |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
560b9c25 | 17 | */ |
a98cef7e | 18 | |
6d14383e AW |
19 | /* This file is included in vm.c multiple times */ |
20 | ||
21 | #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) | |
ff3968c2 | 22 | # define VM_USE_HOOKS 0 /* Various hooks */ |
6d14383e | 23 | #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) |
ff3968c2 | 24 | # define VM_USE_HOOKS 1 |
6d14383e | 25 | #else |
ff3968c2 | 26 | # error unknown debug engine VM_ENGINE |
6d14383e | 27 | #endif |
a98cef7e | 28 | |
8dd6bfa7 AW |
29 | /* Assign some registers by hand. There used to be a bigger list here, |
30 | but it was never tested, and in the case of x86-32, was a source of | |
31 | compilation failures. It can be revived if it's useful, but my naive | |
32 | hope is that simply annotating the locals with "register" will be a | |
33 | sufficient hint to the compiler. */ | |
eac12024 | 34 | #ifdef __GNUC__ |
8dd6bfa7 | 35 | # if defined __x86_64__ |
eac12024 AW |
36 | /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works |
37 | well. Tell it to keep the jump table in a r12, which is | |
38 | callee-saved. */ | |
8dd6bfa7 AW |
39 | # define JT_REG asm ("r12") |
40 | # endif | |
eac12024 AW |
41 | #endif |
42 | ||
43 | #ifndef IP_REG | |
8dd6bfa7 | 44 | # define IP_REG |
eac12024 AW |
45 | #endif |
46 | #ifndef SP_REG | |
8dd6bfa7 | 47 | # define SP_REG |
eac12024 AW |
48 | #endif |
49 | #ifndef FP_REG | |
8dd6bfa7 | 50 | # define FP_REG |
eac12024 AW |
51 | #endif |
52 | #ifndef JT_REG | |
8dd6bfa7 | 53 | # define JT_REG |
eac12024 AW |
54 | #endif |
55 | ||
27c7c630 AW |
56 | #define VM_ASSERT(condition, handler) \ |
57 | do { \ | |
58 | if (SCM_UNLIKELY (!(condition))) \ | |
59 | { \ | |
60 | SYNC_ALL(); \ | |
61 | handler; \ | |
62 | } \ | |
63 | } while (0) | |
eac12024 AW |
64 | |
65 | #ifdef VM_ENABLE_ASSERTIONS | |
66 | # define ASSERT(condition) VM_ASSERT (condition, abort()) | |
67 | #else | |
68 | # define ASSERT(condition) | |
69 | #endif | |
70 | ||
c850a0ff AW |
71 | #if VM_USE_HOOKS |
72 | #define RUN_HOOK(h, args, n) \ | |
73 | do { \ | |
74 | if (SCM_UNLIKELY (vp->trace_level > 0)) \ | |
75 | { \ | |
76 | SYNC_REGISTER (); \ | |
77 | vm_dispatch_hook (vm, h, args, n); \ | |
78 | } \ | |
79 | } while (0) | |
80 | #else | |
81 | #define RUN_HOOK(h, args, n) | |
82 | #endif | |
83 | #define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0) | |
84 | ||
85 | #define APPLY_HOOK() \ | |
86 | RUN_HOOK0 (SCM_VM_APPLY_HOOK) | |
87 | #define PUSH_CONTINUATION_HOOK() \ | |
88 | RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK) | |
89 | #define POP_CONTINUATION_HOOK(vals, n) \ | |
90 | RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n) | |
91 | #define NEXT_HOOK() \ | |
92 | RUN_HOOK0 (SCM_VM_NEXT_HOOK) | |
93 | #define ABORT_CONTINUATION_HOOK(vals, n) \ | |
94 | RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n) | |
95 | #define RESTORE_CONTINUATION_HOOK() \ | |
96 | RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK) | |
97 | ||
98 | #define VM_HANDLE_INTERRUPTS \ | |
99 | SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ()) | |
100 | ||
101 | ||
102 | \f | |
eac12024 AW |
103 | |
104 | /* Cache the VM's instruction, stack, and frame pointer in local variables. */ | |
105 | #define CACHE_REGISTER() \ | |
106 | { \ | |
107 | ip = vp->ip; \ | |
108 | sp = vp->sp; \ | |
109 | fp = vp->fp; \ | |
110 | } | |
111 | ||
112 | /* Update the registers in VP, a pointer to the current VM. This must be done | |
113 | at least before any GC invocation so that `vp->sp' is up-to-date and the | |
114 | whole stack gets marked. */ | |
115 | #define SYNC_REGISTER() \ | |
116 | { \ | |
117 | vp->ip = ip; \ | |
118 | vp->sp = sp; \ | |
119 | vp->fp = fp; \ | |
120 | } | |
121 | ||
122 | /* FIXME */ | |
123 | #define ASSERT_VARIABLE(x) \ | |
27c7c630 | 124 | VM_ASSERT (SCM_VARIABLEP (x), abort()) |
eac12024 | 125 | #define ASSERT_BOUND_VARIABLE(x) \ |
27c7c630 AW |
126 | VM_ASSERT (SCM_VARIABLEP (x) \ |
127 | && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \ | |
128 | abort()) | |
eac12024 AW |
129 | |
130 | #ifdef VM_ENABLE_PARANOID_ASSERTIONS | |
131 | #define CHECK_IP() \ | |
132 | do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) | |
133 | #define ASSERT_ALIGNED_PROCEDURE() \ | |
134 | do { if ((scm_t_bits)bp % 8) abort (); } while (0) | |
135 | #define ASSERT_BOUND(x) \ | |
27c7c630 | 136 | VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort()) |
eac12024 AW |
137 | #else |
138 | #define CHECK_IP() | |
139 | #define ASSERT_ALIGNED_PROCEDURE() | |
140 | #define ASSERT_BOUND(x) | |
141 | #endif | |
142 | ||
eac12024 AW |
143 | /* Cache the object table and free variables. */ |
144 | #define CACHE_PROGRAM() \ | |
145 | { \ | |
146 | if (bp != SCM_PROGRAM_DATA (program)) { \ | |
147 | bp = SCM_PROGRAM_DATA (program); \ | |
148 | ASSERT_ALIGNED_PROCEDURE (); \ | |
149 | if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \ | |
150 | objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \ | |
eac12024 AW |
151 | } else { \ |
152 | objects = NULL; \ | |
eac12024 AW |
153 | } \ |
154 | } \ | |
155 | } | |
156 | ||
157 | #define SYNC_BEFORE_GC() \ | |
158 | { \ | |
159 | SYNC_REGISTER (); \ | |
160 | } | |
161 | ||
162 | #define SYNC_ALL() \ | |
163 | { \ | |
164 | SYNC_REGISTER (); \ | |
165 | } | |
166 | ||
167 | \f | |
168 | /* | |
169 | * Error check | |
170 | */ | |
171 | ||
172 | /* Accesses to a program's object table. */ | |
eac12024 | 173 | #define CHECK_OBJECT(_num) |
eac12024 | 174 | #define CHECK_FREE_VARIABLE(_num) |
eac12024 AW |
175 | |
176 | \f | |
eac12024 AW |
177 | /* |
178 | * Stack operation | |
179 | */ | |
180 | ||
181 | #ifdef VM_ENABLE_STACK_NULLING | |
182 | # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]); | |
183 | # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1) | |
184 | # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; } | |
185 | /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation | |
186 | inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for | |
187 | that continuation doesn't have a chance to run. It's not important on a | |
188 | semantic level, but it does mess up our stack nulling -- so this macro is to | |
189 | fix that. */ | |
190 | # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp); | |
191 | #else | |
192 | # define CHECK_STACK_LEAKN(_n) | |
193 | # define CHECK_STACK_LEAK() | |
194 | # define NULLSTACK(_n) | |
195 | # define NULLSTACK_FOR_NONLOCAL_EXIT() | |
196 | #endif | |
197 | ||
198 | /* For this check, we don't use VM_ASSERT, because that leads to a | |
199 | per-site SYNC_ALL, which is too much code growth. The real problem | |
200 | of course is having to check for overflow all the time... */ | |
201 | #define CHECK_OVERFLOW() \ | |
202 | do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0) | |
203 | ||
204 | #ifdef VM_CHECK_UNDERFLOW | |
205 | #define PRE_CHECK_UNDERFLOW(N) \ | |
206 | VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ()) | |
207 | #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0) | |
208 | #else | |
209 | #define PRE_CHECK_UNDERFLOW(N) /* nop */ | |
210 | #define CHECK_UNDERFLOW() /* nop */ | |
211 | #endif | |
212 | ||
213 | ||
214 | #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) | |
215 | #define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0) | |
216 | #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0) | |
217 | #define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0) | |
218 | #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0) | |
219 | #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0) | |
220 | ||
eac12024 AW |
221 | /* Pop the N objects on top of the stack and push a list that contains |
222 | them. */ | |
223 | #define POP_LIST(n) \ | |
224 | do \ | |
225 | { \ | |
226 | int i; \ | |
227 | SCM l = SCM_EOL, x; \ | |
52182d52 | 228 | SYNC_BEFORE_GC (); \ |
eac12024 AW |
229 | for (i = n; i; i--) \ |
230 | { \ | |
231 | POP (x); \ | |
52182d52 | 232 | l = scm_cons (x, l); \ |
eac12024 AW |
233 | } \ |
234 | PUSH (l); \ | |
235 | } while (0) | |
236 | ||
237 | /* The opposite: push all of the elements in L onto the list. */ | |
238 | #define PUSH_LIST(l, NILP) \ | |
239 | do \ | |
240 | { \ | |
241 | for (; scm_is_pair (l); l = SCM_CDR (l)) \ | |
242 | PUSH (SCM_CAR (l)); \ | |
243 | VM_ASSERT (NILP (l), vm_error_improper_list (l)); \ | |
244 | } while (0) | |
245 | ||
246 | \f | |
eac12024 AW |
247 | /* |
248 | * Instruction operation | |
249 | */ | |
250 | ||
251 | #define FETCH() (*ip++) | |
252 | #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0) | |
253 | ||
254 | #undef NEXT_JUMP | |
255 | #ifdef HAVE_LABELS_AS_VALUES | |
27c7c630 | 256 | # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK] |
eac12024 | 257 | #else |
27c7c630 | 258 | # define NEXT_JUMP() goto vm_start |
eac12024 AW |
259 | #endif |
260 | ||
261 | #define NEXT \ | |
262 | { \ | |
263 | NEXT_HOOK (); \ | |
264 | CHECK_STACK_LEAK (); \ | |
265 | NEXT_JUMP (); \ | |
266 | } | |
267 | ||
268 | \f | |
269 | /* See frames.h for the layout of stack frames */ | |
270 | /* When this is called, bp points to the new program data, | |
271 | and the arguments are already on the stack */ | |
272 | #define DROP_FRAME() \ | |
273 | { \ | |
274 | sp -= 3; \ | |
275 | NULLSTACK (3); \ | |
276 | CHECK_UNDERFLOW (); \ | |
277 | } | |
278 | ||
238e7a11 | 279 | |
a98cef7e | 280 | static SCM |
7656f194 | 281 | VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) |
a98cef7e | 282 | { |
17e90c5e | 283 | /* VM registers */ |
2fb924f6 | 284 | register scm_t_uint8 *ip IP_REG; /* instruction pointer */ |
17e90c5e KN |
285 | register SCM *sp SP_REG; /* stack pointer */ |
286 | register SCM *fp FP_REG; /* frame pointer */ | |
7656f194 | 287 | struct scm_vm *vp = SCM_VM_DATA (vm); |
a98cef7e | 288 | |
d608d68d | 289 | /* Cache variables */ |
53e28ed9 | 290 | struct scm_objcode *bp = NULL; /* program base pointer */ |
17e90c5e | 291 | SCM *objects = NULL; /* constant objects */ |
3d5ee0cd | 292 | SCM *stack_limit = vp->stack_limit; /* stack limit address */ |
2d026f04 | 293 | |
a2a6c0e3 | 294 | scm_i_thread *current_thread = SCM_I_CURRENT_THREAD; |
a98cef7e | 295 | |
d608d68d | 296 | /* Internal variables */ |
ef24c01b | 297 | int nvalues = 0; |
9d381ba4 AW |
298 | scm_i_jmp_buf registers; /* used for prompts */ |
299 | ||
53e28ed9 | 300 | #ifdef HAVE_LABELS_AS_VALUES |
37a5970c | 301 | static const void **jump_table_pointer = NULL; |
e06e857c | 302 | #endif |
37a5970c | 303 | |
e06e857c | 304 | #ifdef HAVE_LABELS_AS_VALUES |
37a5970c LC |
305 | register const void **jump_table JT_REG; |
306 | ||
307 | if (SCM_UNLIKELY (!jump_table_pointer)) | |
53e28ed9 AW |
308 | { |
309 | int i; | |
37a5970c | 310 | jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); |
53e28ed9 | 311 | for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) |
37a5970c | 312 | jump_table_pointer[i] = &&vm_error_bad_instruction; |
53e28ed9 | 313 | #define VM_INSTRUCTION_TO_LABEL 1 |
37a5970c | 314 | #define jump_table jump_table_pointer |
aeeff258 AW |
315 | #include <libguile/vm-expand.h> |
316 | #include <libguile/vm-i-system.i> | |
317 | #include <libguile/vm-i-scheme.i> | |
318 | #include <libguile/vm-i-loader.i> | |
37a5970c | 319 | #undef jump_table |
53e28ed9 AW |
320 | #undef VM_INSTRUCTION_TO_LABEL |
321 | } | |
37a5970c LC |
322 | |
323 | /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one | |
324 | load instruction at each instruction dispatch. */ | |
325 | jump_table = jump_table_pointer; | |
53e28ed9 | 326 | #endif |
9d381ba4 AW |
327 | |
328 | if (SCM_I_SETJMP (registers)) | |
329 | { | |
330 | /* Non-local return. Cache the VM registers back from the vp, and | |
331 | go to the handler. | |
332 | ||
333 | Note, at this point, we must assume that any variable local to | |
334 | vm_engine that can be assigned *has* been assigned. So we need to pull | |
335 | all our state back from the ip/fp/sp. | |
336 | */ | |
337 | CACHE_REGISTER (); | |
338 | program = SCM_FRAME_PROGRAM (fp); | |
339 | CACHE_PROGRAM (); | |
340 | /* The stack contains the values returned to this continuation, | |
341 | along with a number-of-values marker -- like an MV return. */ | |
c850a0ff | 342 | ABORT_CONTINUATION_HOOK (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp)); |
9d381ba4 AW |
343 | NEXT; |
344 | } | |
53e28ed9 | 345 | |
67b699cc | 346 | CACHE_REGISTER (); |
27319ffa AW |
347 | |
348 | /* Since it's possible to receive the arguments on the stack itself, | |
349 | and indeed the RTL VM invokes us that way, shuffle up the | |
350 | arguments first. */ | |
351 | VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs)); | |
352 | { | |
353 | int i; | |
354 | for (i = nargs - 1; i >= 0; i--) | |
355 | sp[9 + i] = argv[i]; | |
356 | } | |
357 | ||
358 | /* Initial frame */ | |
67b699cc AW |
359 | PUSH (SCM_PACK (fp)); /* dynamic link */ |
360 | PUSH (SCM_PACK (0)); /* mvra */ | |
361 | PUSH (SCM_PACK (ip)); /* ra */ | |
362 | PUSH (boot_continuation); | |
363 | fp = sp + 1; | |
364 | ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation)); | |
365 | ||
366 | /* MV-call frame, function & arguments */ | |
367 | PUSH (SCM_PACK (fp)); /* dynamic link */ | |
368 | PUSH (SCM_PACK (ip + 1)); /* mvra */ | |
369 | PUSH (SCM_PACK (ip)); /* ra */ | |
370 | PUSH (program); | |
371 | fp = sp + 1; | |
27319ffa | 372 | sp += nargs; |
67b699cc AW |
373 | |
374 | PUSH_CONTINUATION_HOOK (); | |
375 | ||
376 | apply: | |
377 | program = fp[-1]; | |
378 | if (!SCM_PROGRAM_P (program)) | |
379 | { | |
380 | if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) | |
381 | fp[-1] = SCM_STRUCT_PROCEDURE (program); | |
968a9add | 382 | else if (SCM_HAS_TYP7 (program, scm_tc7_smob) |
67b699cc AW |
383 | && SCM_SMOB_APPLICABLE_P (program)) |
384 | { | |
385 | /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */ | |
386 | int i; | |
387 | PUSH (SCM_BOOL_F); | |
388 | for (i = sp - fp; i >= 0; i--) | |
389 | fp[i] = fp[i - 1]; | |
968a9add | 390 | fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline; |
67b699cc AW |
391 | } |
392 | else | |
393 | { | |
394 | SYNC_ALL(); | |
395 | vm_error_wrong_type_apply (program); | |
396 | } | |
397 | goto apply; | |
398 | } | |
399 | ||
400 | CACHE_PROGRAM (); | |
401 | ip = SCM_C_OBJCODE_BASE (bp); | |
402 | ||
403 | APPLY_HOOK (); | |
a98cef7e KN |
404 | |
405 | /* Let's go! */ | |
53e28ed9 | 406 | NEXT; |
a98cef7e KN |
407 | |
408 | #ifndef HAVE_LABELS_AS_VALUES | |
17e90c5e | 409 | vm_start: |
53e28ed9 | 410 | switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) { |
a98cef7e KN |
411 | #endif |
412 | ||
83495480 AW |
413 | #include "vm-expand.h" |
414 | #include "vm-i-system.c" | |
415 | #include "vm-i-scheme.c" | |
416 | #include "vm-i-loader.c" | |
a98cef7e KN |
417 | |
418 | #ifndef HAVE_LABELS_AS_VALUES | |
53e28ed9 AW |
419 | default: |
420 | goto vm_error_bad_instruction; | |
a98cef7e KN |
421 | } |
422 | #endif | |
423 | ||
53bdfcf0 | 424 | abort (); /* never reached */ |
a52b2d3d | 425 | |
53bdfcf0 AW |
426 | vm_error_bad_instruction: |
427 | vm_error_bad_instruction (ip[-1]); | |
428 | abort (); /* never reached */ | |
17e90c5e | 429 | |
53bdfcf0 AW |
430 | handle_overflow: |
431 | SYNC_ALL (); | |
432 | vm_error_stack_overflow (vp); | |
a98cef7e KN |
433 | abort (); /* never reached */ |
434 | } | |
6d14383e | 435 | |
27c7c630 AW |
436 | #undef RUN_HOOK |
437 | #undef RUN_HOOK1 | |
6d14383e | 438 | #undef VM_USE_HOOKS |
17e90c5e KN |
439 | |
440 | /* | |
441 | Local Variables: | |
442 | c-file-style: "gnu" | |
443 | End: | |
444 | */ |