Commit | Line | Data |
---|---|---|
a98cef7e KN |
1 | /* Copyright (C) 2000 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | * Boston, MA 02111-1307 USA | |
17 | * | |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
40 | * If you do not wish that, delete this exception notice. */ | |
41 | ||
17e90c5e KN |
42 | #include <string.h> |
43 | #include "instructions.h" | |
44 | #include "programs.h" | |
45 | #include "envs.h" | |
a98cef7e KN |
46 | #include "vm.h" |
47 | ||
a98cef7e KN |
48 | /* I sometimes use this for debugging. */ |
49 | #define vm_puts(OBJ) \ | |
50 | { \ | |
51 | scm_display (OBJ, scm_def_errp); \ | |
52 | scm_newline (scm_def_errp); \ | |
53 | } | |
54 | ||
55 | \f | |
e6db4668 | 56 | /* |
3616e9e9 | 57 | * VM Heap frame |
a98cef7e KN |
58 | */ |
59 | ||
3616e9e9 | 60 | scm_bits_t scm_tc16_vm_heap_frame; |
a98cef7e KN |
61 | |
62 | static SCM | |
3616e9e9 | 63 | make_vm_heap_frame (SCM *fp) |
a98cef7e | 64 | { |
3616e9e9 KN |
65 | struct scm_vm_heap_frame *p = |
66 | scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame"); | |
67 | p->fp = fp; | |
68 | p->program = SCM_UNDEFINED; | |
69 | p->variables = SCM_UNDEFINED; | |
70 | p->dynamic_link = SCM_UNDEFINED; | |
71 | SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p); | |
a98cef7e KN |
72 | } |
73 | ||
74 | static SCM | |
3616e9e9 | 75 | vm_heap_frame_mark (SCM obj) |
a98cef7e | 76 | { |
3616e9e9 KN |
77 | struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj); |
78 | scm_gc_mark (p->program); | |
79 | scm_gc_mark (p->variables); | |
80 | return p->dynamic_link; | |
a98cef7e KN |
81 | } |
82 | ||
83 | /* Scheme interface */ | |
84 | ||
85 | SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, | |
86 | (SCM obj), | |
17e90c5e | 87 | "") |
a98cef7e KN |
88 | #define FUNC_NAME s_scm_frame_p |
89 | { | |
3616e9e9 | 90 | return SCM_BOOL (SCM_VM_HEAP_FRAME_P (obj)); |
a98cef7e KN |
91 | } |
92 | #undef FUNC_NAME | |
93 | ||
94 | SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, | |
95 | (SCM frame), | |
17e90c5e | 96 | "") |
a98cef7e KN |
97 | #define FUNC_NAME s_scm_frame_program |
98 | { | |
3616e9e9 KN |
99 | SCM_VALIDATE_VM_HEAP_FRAME (1, frame); |
100 | return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp); | |
a98cef7e KN |
101 | } |
102 | #undef FUNC_NAME | |
103 | ||
104 | SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, | |
105 | (SCM frame), | |
17e90c5e | 106 | "") |
a98cef7e KN |
107 | #define FUNC_NAME s_scm_frame_variables |
108 | { | |
3616e9e9 KN |
109 | struct scm_vm_heap_frame *p; |
110 | ||
111 | SCM_VALIDATE_VM_HEAP_FRAME (1, frame); | |
112 | p = SCM_VM_HEAP_FRAME_DATA (frame); | |
113 | ||
114 | if (SCM_UNBNDP (p->variables)) | |
115 | { | |
116 | SCM prog = scm_frame_program (frame); | |
117 | int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog); | |
118 | p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); | |
119 | for (i = 0; i < size; i++) | |
120 | SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (p->fp, i); | |
121 | } | |
122 | return p->variables; | |
a98cef7e KN |
123 | } |
124 | #undef FUNC_NAME | |
125 | ||
126 | SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, | |
127 | (SCM frame), | |
17e90c5e | 128 | "") |
a98cef7e KN |
129 | #define FUNC_NAME s_scm_frame_dynamic_link |
130 | { | |
3616e9e9 KN |
131 | struct scm_vm_heap_frame *p; |
132 | ||
133 | SCM_VALIDATE_VM_HEAP_FRAME (1, frame); | |
134 | p = SCM_VM_HEAP_FRAME_DATA (frame); | |
135 | ||
136 | if (SCM_UNBNDP (p->dynamic_link)) | |
137 | { | |
138 | SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp)); | |
139 | if (fp) | |
140 | p->dynamic_link = make_vm_heap_frame (fp); | |
141 | else | |
142 | p->dynamic_link = SCM_BOOL_F; | |
143 | } | |
144 | ||
145 | return p->dynamic_link; | |
a98cef7e KN |
146 | } |
147 | #undef FUNC_NAME | |
148 | ||
149 | \f | |
150 | /* | |
151 | * VM Continuation | |
152 | */ | |
153 | ||
17e90c5e KN |
154 | scm_bits_t scm_tc16_vm_cont; |
155 | ||
156 | ||
157 | #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) | |
3d5ee0cd | 158 | #define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) |
a98cef7e KN |
159 | |
160 | static SCM | |
3d5ee0cd | 161 | capture_vm_cont (struct scm_vm *vp) |
a98cef7e KN |
162 | { |
163 | struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont"); | |
3d5ee0cd | 164 | p->stack_size = vp->stack_limit - vp->sp; |
a98cef7e KN |
165 | p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM), |
166 | "capture_vm_cont"); | |
17e90c5e | 167 | p->stack_limit = p->stack_base + p->stack_size - 2; |
3d5ee0cd KN |
168 | p->ip = vp->ip; |
169 | p->sp = (SCM *) (vp->stack_limit - vp->sp); | |
170 | p->fp = (SCM *) (vp->stack_limit - vp->fp); | |
171 | memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM)); | |
17e90c5e | 172 | SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p); |
a98cef7e KN |
173 | } |
174 | ||
175 | static void | |
3d5ee0cd | 176 | reinstate_vm_cont (struct scm_vm *vp, SCM cont) |
a98cef7e | 177 | { |
3d5ee0cd KN |
178 | struct scm_vm *p = SCM_VM_CONT_VP (cont); |
179 | if (vp->stack_size < p->stack_size) | |
a98cef7e | 180 | { |
17e90c5e | 181 | /* puts ("FIXME: Need to expand"); */ |
a98cef7e KN |
182 | abort (); |
183 | } | |
3d5ee0cd KN |
184 | vp->ip = p->ip; |
185 | vp->sp = vp->stack_limit - (int) p->sp; | |
186 | vp->fp = vp->stack_limit - (int) p->fp; | |
187 | memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); | |
a98cef7e KN |
188 | } |
189 | ||
190 | static SCM | |
17e90c5e | 191 | vm_cont_mark (SCM obj) |
a98cef7e KN |
192 | { |
193 | SCM *p; | |
3d5ee0cd KN |
194 | struct scm_vm *vp = SCM_VM_CONT_VP (obj); |
195 | for (p = vp->stack_base; p <= vp->stack_limit; p++) | |
a98cef7e KN |
196 | if (SCM_NIMP (*p)) |
197 | scm_gc_mark (*p); | |
198 | return SCM_BOOL_F; | |
199 | } | |
200 | ||
201 | static scm_sizet | |
17e90c5e | 202 | vm_cont_free (SCM obj) |
a98cef7e | 203 | { |
3d5ee0cd | 204 | struct scm_vm *p = SCM_VM_CONT_VP (obj); |
a98cef7e KN |
205 | int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM); |
206 | scm_must_free (p->stack_base); | |
207 | scm_must_free (p); | |
208 | return size; | |
209 | } | |
210 | ||
17e90c5e KN |
211 | \f |
212 | /* | |
213 | * VM Internal functions | |
214 | */ | |
215 | ||
216 | SCM_SYMBOL (sym_vm_engine, "vm-engine"); | |
217 | SCM_SYMBOL (sym_vm_error, "vm-error"); | |
218 | ||
219 | static scm_byte_t * | |
220 | vm_fetch_length (scm_byte_t *ip, size_t *lenp) | |
a98cef7e | 221 | { |
4bfb26f5 | 222 | /* NOTE: format defined in system/vm/conv.scm */ |
17e90c5e KN |
223 | *lenp = *ip++; |
224 | if (*lenp < 254) | |
225 | return ip; | |
226 | else if (*lenp == 254) | |
46cd9a34 KN |
227 | { |
228 | int b1 = *ip++; | |
229 | int b2 = *ip++; | |
230 | *lenp = (b1 << 8) + b2; | |
231 | } | |
17e90c5e | 232 | else |
46cd9a34 KN |
233 | { |
234 | int b1 = *ip++; | |
235 | int b2 = *ip++; | |
236 | int b3 = *ip++; | |
237 | int b4 = *ip++; | |
238 | *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4; | |
239 | } | |
17e90c5e | 240 | return ip; |
a98cef7e KN |
241 | } |
242 | ||
243 | \f | |
244 | /* | |
245 | * VM | |
246 | */ | |
247 | ||
499a4c07 | 248 | #define VM_DEFAULT_STACK_SIZE (4 * 1024) |
17e90c5e KN |
249 | |
250 | #define VM_REGULAR_ENGINE 0 | |
251 | #define VM_DEBUG_ENGINE 1 | |
252 | ||
253 | #if 0 | |
254 | #define VM_NAME vm_regular_engine | |
255 | #define VM_ENGINE VM_REGULAR_ENGINE | |
256 | #include "vm_engine.c" | |
257 | #undef VM_NAME | |
258 | #undef VM_ENGINE | |
259 | #endif | |
260 | ||
261 | #define VM_NAME vm_debug_engine | |
262 | #define VM_ENGINE VM_DEBUG_ENGINE | |
263 | #include "vm_engine.c" | |
264 | #undef VM_NAME | |
265 | #undef VM_ENGINE | |
266 | ||
267 | scm_bits_t scm_tc16_vm; | |
a98cef7e | 268 | |
499a4c07 KN |
269 | static SCM the_vm; |
270 | ||
a98cef7e | 271 | static SCM |
17e90c5e KN |
272 | make_vm (void) |
273 | #define FUNC_NAME "make_vm" | |
a98cef7e | 274 | { |
17e90c5e | 275 | int i; |
3d5ee0cd KN |
276 | struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm)); |
277 | vp->stack_size = VM_DEFAULT_STACK_SIZE; | |
278 | vp->stack_base = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM)); | |
3616e9e9 KN |
279 | vp->stack_limit = vp->stack_base + vp->stack_size - 3; |
280 | vp->ip = NULL; | |
281 | vp->sp = vp->stack_base - 1; | |
282 | vp->fp = NULL; | |
3d5ee0cd KN |
283 | vp->time = 0; |
284 | vp->clock = 0; | |
285 | vp->options = SCM_EOL; | |
17e90c5e | 286 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) |
3d5ee0cd KN |
287 | vp->hooks[i] = SCM_BOOL_F; |
288 | SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); | |
a98cef7e | 289 | } |
17e90c5e | 290 | #undef FUNC_NAME |
a98cef7e KN |
291 | |
292 | static SCM | |
17e90c5e | 293 | vm_mark (SCM obj) |
a98cef7e | 294 | { |
17e90c5e KN |
295 | int i; |
296 | SCM *sp, *fp; | |
3d5ee0cd | 297 | struct scm_vm *vp = SCM_VM_DATA (obj); |
17e90c5e KN |
298 | |
299 | /* Mark the stack */ | |
3d5ee0cd KN |
300 | sp = vp->sp; |
301 | fp = vp->fp; | |
17e90c5e KN |
302 | while (fp) |
303 | { | |
304 | SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp); | |
305 | SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp); | |
306 | /* Mark intermediate data */ | |
3616e9e9 | 307 | for (; sp >= upper; sp--) |
17e90c5e KN |
308 | if (SCM_NIMP (*sp)) |
309 | scm_gc_mark (*sp); | |
3616e9e9 KN |
310 | fp = SCM_VM_STACK_ADDRESS (*sp); /* dynamic link */ |
311 | /* Mark frame variables + program */ | |
312 | for (sp -= 2; sp >= lower; sp--) | |
17e90c5e KN |
313 | if (SCM_NIMP (*sp)) |
314 | scm_gc_mark (*sp); | |
17e90c5e | 315 | } |
a98cef7e | 316 | |
17e90c5e KN |
317 | /* Mark the options */ |
318 | for (i = 0; i < SCM_VM_NUM_HOOKS; i++) | |
3d5ee0cd KN |
319 | scm_gc_mark (vp->hooks[i]); |
320 | return vp->options; | |
a98cef7e KN |
321 | } |
322 | ||
17e90c5e KN |
323 | static scm_sizet |
324 | vm_free (SCM obj) | |
325 | { | |
3d5ee0cd KN |
326 | struct scm_vm *vp = SCM_VM_DATA (obj); |
327 | int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM)); | |
328 | scm_must_free (vp->stack_base); | |
329 | scm_must_free (vp); | |
17e90c5e KN |
330 | return size; |
331 | } | |
332 | ||
333 | SCM_SYMBOL (sym_debug, "debug"); | |
334 | ||
335 | SCM | |
336 | scm_vm_apply (SCM vm, SCM program, SCM args) | |
337 | #define FUNC_NAME "scm_vm_apply" | |
a98cef7e | 338 | { |
17e90c5e KN |
339 | SCM_VALIDATE_PROGRAM (1, program); |
340 | return vm_engine (vm, program, args); | |
a98cef7e | 341 | } |
17e90c5e | 342 | #undef FUNC_NAME |
a98cef7e KN |
343 | |
344 | /* Scheme interface */ | |
345 | ||
346 | SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, | |
17e90c5e KN |
347 | (void), |
348 | "") | |
a98cef7e KN |
349 | #define FUNC_NAME s_scm_vm_version |
350 | { | |
351 | return scm_makfrom0str (VERSION); | |
352 | } | |
353 | #undef FUNC_NAME | |
354 | ||
499a4c07 KN |
355 | SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, |
356 | (), | |
357 | "") | |
358 | #define FUNC_NAME s_scm_the_vm | |
359 | { | |
360 | return the_vm; | |
361 | } | |
362 | #undef FUNC_NAME | |
363 | ||
364 | ||
a98cef7e KN |
365 | SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, |
366 | (SCM obj), | |
17e90c5e | 367 | "") |
a98cef7e KN |
368 | #define FUNC_NAME s_scm_vm_p |
369 | { | |
370 | return SCM_BOOL (SCM_VM_P (obj)); | |
371 | } | |
372 | #undef FUNC_NAME | |
373 | ||
374 | SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, | |
17e90c5e KN |
375 | (void), |
376 | "") | |
377 | #define FUNC_NAME s_scm_make_vm, | |
a98cef7e | 378 | { |
17e90c5e | 379 | return make_vm (); |
a98cef7e KN |
380 | } |
381 | #undef FUNC_NAME | |
382 | ||
17e90c5e | 383 | SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, |
a98cef7e | 384 | (SCM vm), |
17e90c5e KN |
385 | "") |
386 | #define FUNC_NAME s_scm_vm_ip | |
a98cef7e KN |
387 | { |
388 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 389 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->ip); |
a98cef7e KN |
390 | } |
391 | #undef FUNC_NAME | |
392 | ||
393 | SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, | |
394 | (SCM vm), | |
17e90c5e | 395 | "") |
a98cef7e KN |
396 | #define FUNC_NAME s_scm_vm_sp |
397 | { | |
398 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 399 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->sp); |
a98cef7e KN |
400 | } |
401 | #undef FUNC_NAME | |
402 | ||
403 | SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, | |
404 | (SCM vm), | |
17e90c5e | 405 | "") |
a98cef7e KN |
406 | #define FUNC_NAME s_scm_vm_fp |
407 | { | |
408 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 409 | return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp); |
a98cef7e KN |
410 | } |
411 | #undef FUNC_NAME | |
412 | ||
17e90c5e KN |
413 | #define VM_DEFINE_HOOK(n) \ |
414 | { \ | |
3d5ee0cd | 415 | struct scm_vm *vp; \ |
17e90c5e | 416 | SCM_VALIDATE_VM (1, vm); \ |
3d5ee0cd KN |
417 | vp = SCM_VM_DATA (vm); \ |
418 | if (SCM_FALSEP (vp->hooks[n])) \ | |
419 | vp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \ | |
420 | return vp->hooks[n]; \ | |
17e90c5e KN |
421 | } |
422 | ||
423 | SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, | |
a98cef7e | 424 | (SCM vm), |
17e90c5e KN |
425 | "") |
426 | #define FUNC_NAME s_scm_vm_boot_hook | |
a98cef7e | 427 | { |
17e90c5e | 428 | VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); |
a98cef7e KN |
429 | } |
430 | #undef FUNC_NAME | |
431 | ||
17e90c5e KN |
432 | SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, |
433 | (SCM vm), | |
434 | "") | |
435 | #define FUNC_NAME s_scm_vm_halt_hook | |
a98cef7e | 436 | { |
17e90c5e | 437 | VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); |
a98cef7e KN |
438 | } |
439 | #undef FUNC_NAME | |
440 | ||
17e90c5e | 441 | SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, |
a98cef7e | 442 | (SCM vm), |
17e90c5e KN |
443 | "") |
444 | #define FUNC_NAME s_scm_vm_next_hook | |
a98cef7e | 445 | { |
17e90c5e | 446 | VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); |
a98cef7e KN |
447 | } |
448 | #undef FUNC_NAME | |
449 | ||
17e90c5e KN |
450 | SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, |
451 | (SCM vm), | |
452 | "") | |
453 | #define FUNC_NAME s_scm_vm_enter_hook | |
a98cef7e | 454 | { |
17e90c5e | 455 | VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); |
a98cef7e KN |
456 | } |
457 | #undef FUNC_NAME | |
458 | ||
17e90c5e KN |
459 | SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, |
460 | (SCM vm), | |
461 | "") | |
462 | #define FUNC_NAME s_scm_vm_apply_hook | |
a98cef7e | 463 | { |
17e90c5e | 464 | VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); |
a98cef7e KN |
465 | } |
466 | #undef FUNC_NAME | |
467 | ||
17e90c5e | 468 | SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, |
a98cef7e | 469 | (SCM vm), |
17e90c5e KN |
470 | "") |
471 | #define FUNC_NAME s_scm_vm_exit_hook | |
a98cef7e | 472 | { |
17e90c5e | 473 | VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); |
a98cef7e KN |
474 | } |
475 | #undef FUNC_NAME | |
476 | ||
17e90c5e | 477 | SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, |
a98cef7e | 478 | (SCM vm), |
17e90c5e KN |
479 | "") |
480 | #define FUNC_NAME s_scm_vm_return_hook | |
a98cef7e | 481 | { |
17e90c5e | 482 | VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); |
a98cef7e KN |
483 | } |
484 | #undef FUNC_NAME | |
485 | ||
17e90c5e KN |
486 | SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0, |
487 | (SCM vm, SCM key), | |
488 | "") | |
489 | #define FUNC_NAME s_scm_vm_option | |
a98cef7e KN |
490 | { |
491 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 492 | return scm_assq_ref (SCM_VM_DATA (vm)->options, key); |
a98cef7e KN |
493 | } |
494 | #undef FUNC_NAME | |
495 | ||
17e90c5e KN |
496 | SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, |
497 | (SCM vm, SCM key, SCM val), | |
498 | "") | |
499 | #define FUNC_NAME s_scm_set_vm_option_x | |
a98cef7e KN |
500 | { |
501 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e KN |
502 | SCM_VM_DATA (vm)->options |
503 | = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); | |
504 | return SCM_UNSPECIFIED; | |
a98cef7e KN |
505 | } |
506 | #undef FUNC_NAME | |
507 | ||
17e90c5e | 508 | SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, |
a98cef7e | 509 | (SCM vm), |
17e90c5e KN |
510 | "") |
511 | #define FUNC_NAME s_scm_vm_stats | |
a98cef7e | 512 | { |
17e90c5e KN |
513 | SCM stats; |
514 | ||
a98cef7e | 515 | SCM_VALIDATE_VM (1, vm); |
17e90c5e | 516 | |
499a4c07 KN |
517 | stats = scm_c_make_vector (2, SCM_MAKINUM (0)); |
518 | SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->time); | |
519 | SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->clock); | |
17e90c5e KN |
520 | |
521 | return stats; | |
a98cef7e KN |
522 | } |
523 | #undef FUNC_NAME | |
524 | ||
17e90c5e KN |
525 | #define VM_CHECK_RUNNING(vm) \ |
526 | if (!SCM_VM_DATA (vm)->ip) \ | |
527 | SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm)) | |
528 | ||
529 | SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, | |
a98cef7e | 530 | (SCM vm), |
17e90c5e KN |
531 | "") |
532 | #define FUNC_NAME s_scm_vm_current_frame | |
a98cef7e KN |
533 | { |
534 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 535 | VM_CHECK_RUNNING (vm); |
3616e9e9 | 536 | return make_vm_heap_frame (SCM_VM_DATA (vm)->fp); |
a98cef7e KN |
537 | } |
538 | #undef FUNC_NAME | |
539 | ||
17e90c5e KN |
540 | SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0, |
541 | (SCM vm), | |
542 | "") | |
543 | #define FUNC_NAME s_scm_vm_fetch_code | |
544 | { | |
545 | int i; | |
546 | SCM list; | |
547 | scm_byte_t *ip; | |
548 | struct scm_instruction *p; | |
a98cef7e | 549 | |
17e90c5e KN |
550 | SCM_VALIDATE_VM (1, vm); |
551 | VM_CHECK_RUNNING (vm); | |
a98cef7e | 552 | |
17e90c5e KN |
553 | ip = SCM_VM_DATA (vm)->ip; |
554 | p = SCM_INSTRUCTION (*ip); | |
a98cef7e | 555 | |
17e90c5e KN |
556 | list = SCM_LIST1 (scm_str2symbol (p->name)); |
557 | for (i = 1; i <= p->len; i++) | |
558 | list = scm_cons (SCM_MAKINUM (ip[i]), list); | |
559 | return scm_reverse_x (list, SCM_EOL); | |
560 | } | |
561 | #undef FUNC_NAME | |
562 | ||
563 | SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, | |
564 | (SCM vm), | |
565 | "") | |
566 | #define FUNC_NAME s_scm_vm_fetch_stack | |
a98cef7e | 567 | { |
3616e9e9 KN |
568 | SCM *sp; |
569 | SCM ls = SCM_EOL; | |
570 | struct scm_vm *vp; | |
a98cef7e KN |
571 | |
572 | SCM_VALIDATE_VM (1, vm); | |
17e90c5e | 573 | VM_CHECK_RUNNING (vm); |
a98cef7e | 574 | |
3616e9e9 KN |
575 | vp = SCM_VM_DATA (vm); |
576 | for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++) | |
577 | ls = scm_cons (*sp, ls); | |
578 | return ls; | |
a98cef7e KN |
579 | } |
580 | #undef FUNC_NAME | |
581 | ||
17e90c5e | 582 | SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0, |
4bfb26f5 | 583 | (SCM vm, SCM bootcode), |
17e90c5e KN |
584 | "") |
585 | #define FUNC_NAME s_scm_vm_load | |
26403690 | 586 | { |
17e90c5e | 587 | SCM prog; |
4bfb26f5 KN |
588 | int len; |
589 | char *base; | |
26403690 KN |
590 | |
591 | SCM_VALIDATE_VM (1, vm); | |
4bfb26f5 | 592 | SCM_VALIDATE_STRING (2, bootcode); |
26403690 | 593 | |
4bfb26f5 KN |
594 | base = SCM_STRING_CHARS (bootcode); |
595 | len = SCM_STRING_LENGTH (bootcode); | |
596 | ||
597 | /* Check bootcode */ | |
598 | if (strncmp (base, "\0GBC", 4) != 0) | |
599 | SCM_MISC_ERROR ("Invalid bootcode: ~S", SCM_LIST1 (bootcode)); | |
600 | ||
601 | /* Create program */ | |
602 | prog = scm_c_make_program (base + 10, len - 10, bootcode); | |
603 | SCM_PROGRAM_NLOCS (prog) = base[8]; | |
604 | SCM_PROGRAM_NEXTS (prog) = base[9]; | |
605 | ||
606 | /* Load it */ | |
17e90c5e | 607 | return scm_vm_apply (vm, prog, SCM_EOL); |
26403690 KN |
608 | } |
609 | #undef FUNC_NAME | |
610 | ||
a98cef7e KN |
611 | \f |
612 | /* | |
17e90c5e | 613 | * Initialize |
a98cef7e KN |
614 | */ |
615 | ||
17e90c5e KN |
616 | void |
617 | scm_init_vm (void) | |
618 | { | |
17e90c5e KN |
619 | scm_init_instructions (); |
620 | scm_init_programs (); | |
a98cef7e | 621 | |
3616e9e9 KN |
622 | scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0); |
623 | scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark); | |
a98cef7e | 624 | |
17e90c5e KN |
625 | scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); |
626 | scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark); | |
627 | scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free); | |
a98cef7e | 628 | |
17e90c5e KN |
629 | scm_tc16_vm = scm_make_smob_type ("vm", 0); |
630 | scm_set_smob_mark (scm_tc16_vm, vm_mark); | |
631 | scm_set_smob_free (scm_tc16_vm, vm_free); | |
632 | scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); | |
a98cef7e | 633 | |
499a4c07 KN |
634 | the_vm = scm_permanent_object (make_vm ()); |
635 | ||
17e90c5e | 636 | #ifndef SCM_MAGIC_SNARFER |
a98cef7e | 637 | #include "vm.x" |
17e90c5e | 638 | #endif |
a98cef7e | 639 | } |
17e90c5e KN |
640 | |
641 | /* | |
642 | Local Variables: | |
643 | c-file-style: "gnu" | |
644 | End: | |
645 | */ |