1 /* vm.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #include <stddef.h>
31 #include <string.h>
32 #define LIBSAGITTARIUS_BODY
33 #include "sagittarius/private/vm.h"
34 #include "sagittarius/private/bignum.h"
35 #include "sagittarius/private/code.h"
36 #include "sagittarius/private/core.h"
37 #include "sagittarius/private/closure.h"
38 #include "sagittarius/private/error.h"
39 #include "sagittarius/private/file.h"
40 #include "sagittarius/private/generic.h"
41 #include "sagittarius/private/hashtable.h"
42 #include "sagittarius/private/identifier.h"
43 #include "sagittarius/private/library.h"
44 #include "sagittarius/private/pair.h"
45 #include "sagittarius/private/port.h"
46 #include "sagittarius/private/transcoder.h"
47 #include "sagittarius/private/reader.h"
48 #include "sagittarius/private/string.h"
49 #include "sagittarius/private/symbol.h"
50 #include "sagittarius/private/instruction.h"
51 #include "sagittarius/private/writer.h"
52 #include "sagittarius/private/number.h"
53 #include "sagittarius/private/macro.h"
54 #include "sagittarius/private/values.h"
55 #include "sagittarius/private/vector.h"
56 #include "sagittarius/private/compare.h"
57 #include "sagittarius/private/system.h"
58 #include "sagittarius/private/exceptions.h"
59 #include "sagittarius/private/profiler.h"
60 #include "sagittarius/private/gloc.h"
61 #include "sagittarius/private/weak.h"
62 #include "sagittarius/private/thread.h"
63 #include "sagittarius/private/unicode.h"
64
65 static SgInternalMutex global_lock;
66
67 static SgVM *rootVM = NULL;
68
69 #if defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
70 static __declspec(thread) SgVM *theVM;
71 #else
72 #include <pthread.h>
73 static pthread_key_t the_vm_key;
74 #define theVM ((SgVM*)pthread_getspecific(the_vm_key))
75 #endif
76
77 static SgSubr default_exception_handler_rec;
78 static SgPair default_exception_handler = {
79 SG_OBJ(&default_exception_handler_rec),
80 SG_NIL,
81 SG_NIL
82 };
83 #define DEFAULT_EXCEPTION_HANDLER SG_OBJ(&default_exception_handler)
84
box_print(SgObject obj,SgPort * port,SgWriteContext * ctx)85 static void box_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
86 {
87 Sg_Printf(port, UC("#<box 0x%x>"), obj);
88 }
89 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_BoxClass, box_print);
90
make_box(SgObject value)91 static inline SgObject make_box(SgObject value)
92 {
93 SgBox *b = SG_NEW(SgBox);
94 SG_SET_CLASS(b, SG_CLASS_BOX);
95 b->value = value;
96 return SG_OBJ(b);
97 }
98
99 static SgObject evaluate_safe(SgObject program, SgWord *compiledCode);
100 static SgObject run_loop();
101
vm_finalize(SgObject obj,void * data)102 static void vm_finalize(SgObject obj, void *data)
103 {
104 SgVM *vm = SG_VM(obj);
105 Sg_RemoveLibrary(vm->currentLibrary);
106 Sg_DestroyMutex(&vm->vmlock);
107 Sg_DestroyCond(&vm->cond);
108 #ifdef _WIN32
109 CloseHandle((&vm->thread)->event);
110 #endif
111 }
112
vm_print(SgObject obj,SgPort * port,SgWriteContext * ctx)113 static void vm_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
114 {
115 char buf[50];
116 SgVM *vm = SG_VM(obj);
117 Sg_Printf(port, UC("#<thread %A"), vm->name);
118 switch (vm->threadState) {
119 case SG_VM_NEW:
120 Sg_Putz(port, " new");
121 break;
122 case SG_VM_RUNNABLE:
123 Sg_Putz(port, " runnable");
124 break;
125 case SG_VM_STOPPED:
126 Sg_Putz(port, " stopped");
127 break;
128 case SG_VM_TERMINATED:
129 Sg_Putz(port, " terminated");
130 break;
131 default:
132 Sg_Putz(port, " (unknonw state)");
133 break;
134 }
135 snprintf(buf, sizeof(buf), " %p>", vm);
136 Sg_Putz(port, buf);
137 }
138
139 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_VMClass, vm_print);
140
copy_generics(SgObject lib)141 static SgObject copy_generics(SgObject lib)
142 {
143 SgObject h = SG_NIL, t = SG_NIL, gs;
144 /* copying cdr part of slot of alist.
145 adding method is done by destructively to avoid
146 to affect it in parent thread. */
147 SG_FOR_EACH(gs, SG_LIBRARY_GENERICS(lib)) {
148 SgObject g = SG_CAR(gs);
149 /* well, it won't hurt anyway :) */
150 SG_APPEND1(h, t, Sg_CopyList(g));
151 }
152 return h;
153 }
154
Sg_NewThreadVM(SgVM * proto,SgObject name)155 SgVM* Sg_NewThreadVM(SgVM *proto, SgObject name)
156 {
157 SgVM *v = SG_NEW(SgVM);
158 int i;
159 SG_SET_CLASS(v, SG_CLASS_VM);
160
161 v->name = name;
162 v->threadErrorP = FALSE;
163 v->threadState = SG_VM_NEW;
164 for (i = 0; i < DEFAULT_VALUES_SIZE; i++) v->values[i] = SG_UNDEF;
165 v->valuesCount = 1;
166
167 v->attentionRequest = FALSE;
168 v->finalizerPending = FALSE;
169 v->stopRequest = FALSE;
170 v->escapePoint = NULL;
171 v->escapeReason = SG_VM_ESCAPE_NONE;
172 v->escapeData[0] = NULL;
173 v->escapeData[1] = NULL;
174 v->cache = SG_NIL;
175 v->cstack = NULL;
176
177 v->dynamicWinders = SG_NIL;
178 v->exceptionHandlers = DEFAULT_EXCEPTION_HANDLER;
179
180 /* from proto */
181 /* if proto was NULL, this will be initialized Sg__InitVM */
182 if (proto) {
183 SgObject nl =
184 Sg_MakeChildLibrary(v, Sg_MakeSymbol(SG_MAKE_STRING("child"), FALSE));
185 Sg_ImportLibrary(nl, proto->currentLibrary);
186 SG_LIBRARY_DEFINEED(nl) = SG_FALSE;
187 v->currentLibrary = nl;
188 v->parameters = Sg_WeakHashTableCopy(proto->parameters);
189 SG_LIBRARY_GENERICS(nl) = copy_generics(proto->currentLibrary);
190 if (!SG_FALSEP(proto->sandbox)) {
191 v->sandbox = Sg_HashTableCopy(proto->sandbox, TRUE);
192 } else {
193 v->sandbox = SG_FALSE;
194 }
195 } else {
196 v->currentLibrary = SG_UNDEF;
197 v->parameters = Sg_MakeWeakHashTableSimple(SG_HASH_EQ, SG_WEAK_KEY, 64,
198 SG_FALSE);
199 v->sandbox = SG_FALSE;
200 }
201 /* child thread should not affect parent load-path*/
202 v->loadPath = proto ? Sg_CopyList(proto->loadPath): SG_NIL;
203 v->dynamicLoadPath = proto ? Sg_CopyList(proto->dynamicLoadPath): SG_NIL;
204 /* default no overwrite */
205 v->flags = proto? proto->flags : 0;
206
207 /* the very initial ones will be initialised in Sg_InitPort() */
208 v->currentInputPort = proto ? proto->currentInputPort : NULL;
209 v->currentOutputPort = proto ? proto->currentOutputPort : NULL;
210 v->currentErrorPort = proto ? proto->currentErrorPort : NULL;
211
212 v->logPort = proto ? proto->logPort : v->currentErrorPort;
213
214 /* thread, mutex, etc */
215 SG_INTERNAL_THREAD_INIT(&v->thread);
216 Sg_InitMutex(&v->vmlock, FALSE);
217 Sg_InitCond(&v->cond);
218 v->inspector = NULL;
219 v->canceller = NULL;
220 v->thunk = NULL;
221 v->specific = SG_FALSE;
222 v->result = SG_UNDEF;
223
224 Sg_RegisterFinalizer(SG_OBJ(v), vm_finalize, NULL);
225 return v;
226 }
227
Sg_SetVMStack(SgVM * vm,SgObject * stack,int stackSize)228 SgVM* Sg_SetVMStack(SgVM *vm, SgObject *stack, int stackSize)
229 {
230 vm->stack = stack;
231 vm->sp = vm->fp = vm->stack;
232 vm->stackEnd = vm->stack + stackSize;
233 vm->cont = (SgContFrame *)vm->sp;
234 vm->ac = SG_NIL;
235 vm->cl = NULL;
236 return vm;
237 }
238
Sg_NewVM(SgVM * proto,SgObject name)239 SgVM* Sg_NewVM(SgVM *proto, SgObject name)
240 {
241 SgVM *vm = Sg_NewThreadVM(proto, name);
242 SgObject *stack = SG_NEW_ARRAY(SgObject, SG_VM_STACK_SIZE);
243 return Sg_SetVMStack(vm, stack, SG_VM_STACK_SIZE);
244 }
245
246 /*
247 Current VM.
248 */
Sg_VM()249 SgVM* Sg_VM()
250 {
251 return theVM;
252 }
253
Sg_AttachVM(SgVM * vm)254 int Sg_AttachVM(SgVM *vm)
255 {
256 if (SG_INTERNAL_THREAD_INITIALIZED_P(&vm->thread)) return FALSE;
257 if (theVM != NULL) return FALSE;
258
259 #if defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
260 theVM = vm;
261 #else
262 if (pthread_setspecific(the_vm_key, vm) != 0) return FALSE;
263 #endif
264 Sg_SetCurrentThread(&vm->thread);
265 vm->threadState = SG_VM_RUNNABLE;
266 return TRUE;
267 }
268
Sg_SetCurrentVM(SgVM * vm)269 int Sg_SetCurrentVM(SgVM *vm)
270 {
271 #if defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
272 theVM = vm;
273 #else
274 if (pthread_setspecific(the_vm_key, vm) != 0) return FALSE;
275 #endif
276 return TRUE;
277 }
278
Sg_MainThreadP()279 int Sg_MainThreadP()
280 {
281 return theVM == rootVM;
282 }
283
Sg_RootVMP(SgVM * vm)284 int Sg_RootVMP(SgVM *vm)
285 {
286 return vm == rootVM;
287 }
288
289 #define Sg_VM() theVM
290
291 /* some convenient accessors */
292 #define PC(vm) (vm)->pc
293 #define AC(vm) (vm)->ac
294 #define CL(vm) (vm)->cl
295 #define FP(vm) (vm)->fp
296 #define SP(vm) (vm)->sp
297 #define CONT(vm) (vm)->cont
298
299 #define INDEX(sp, n) (*((sp) - (n) - 1))
300 #define INDEX_SET(sp, n, v) (*((sp) - (n) - 1) = (v))
301 #define PUSH(sp, o) (*(sp)++ = (o))
302 #define POP(sp) (*(--(sp)))
303
304 /* is the given pointer in the stack? */
305 #define IN_STACK_P(ptr, vm) \
306 ((uintptr_t)((ptr) - vm->stack) < SG_VM_STACK_SIZE)
307
308
309 /* values */
Sg_Values(SgObject args)310 SgObject Sg_Values(SgObject args)
311 {
312 return Sg_VMValues(theVM, args);
313 }
314
Sg_VMValues(SgVM * vm,SgObject args)315 SgObject Sg_VMValues(SgVM *vm, SgObject args)
316 {
317 SgObject cp;
318 int nvals, init = FALSE;
319 int len = -1;
320 if (!SG_PAIRP(args)) {
321 vm->valuesCount = 0;
322 return SG_UNDEF;
323 }
324 nvals = 1;
325
326 SG_FOR_EACH(cp, SG_CDR(args)) {
327 if (nvals < DEFAULT_VALUES_SIZE+1) {
328 SG_VALUES_SET(vm, nvals-1, SG_CAR(cp));
329 } else {
330 if (len < 0) {
331 /* we can't allow too many values so cast it... */
332 len = (int)Sg_Length(cp); /* get rest... */
333 }
334 if (!init) {
335 if (!vm->extra_values || vm->extra_values->buffer_size < len) {
336 SG_ALLOC_VALUES_BUFFER(vm, len);
337 }
338 init = TRUE;
339 }
340 SG_VALUES_SET(vm, nvals-1, SG_CAR(cp));
341 }
342 nvals++;
343 }
344 vm->valuesCount = nvals;
345 vm->ac = SG_CAR(args);
346 return vm->ac;
347 }
348
Sg_Values2(SgObject v1,SgObject v2)349 SgObject Sg_Values2(SgObject v1, SgObject v2)
350 {
351 return Sg_VMValues2(theVM, v1, v2);
352 }
353
Sg_VMValues2(SgVM * vm,SgObject v1,SgObject v2)354 SgObject Sg_VMValues2(SgVM *vm, SgObject v1, SgObject v2)
355 {
356 vm->valuesCount = 2;
357 vm->values[0] = v2;
358 vm->ac = v1;
359 return v1;
360 }
361
Sg_Values3(SgObject v1,SgObject v2,SgObject v3)362 SgObject Sg_Values3(SgObject v1, SgObject v2, SgObject v3)
363 {
364 return Sg_VMValues3(theVM, v1, v2, v3);
365 }
366
Sg_VMValues3(SgVM * vm,SgObject v1,SgObject v2,SgObject v3)367 SgObject Sg_VMValues3(SgVM *vm, SgObject v1, SgObject v2, SgObject v3)
368 {
369 vm->valuesCount = 3;
370 vm->values[0] = v2;
371 vm->values[1] = v3;
372 vm->ac = v1;
373 return v1;
374 }
375
Sg_Values4(SgObject v1,SgObject v2,SgObject v3,SgObject v4)376 SgObject Sg_Values4(SgObject v1, SgObject v2, SgObject v3, SgObject v4)
377 {
378 return Sg_VMValues4(theVM, v1, v2, v3, v4);
379 }
380
Sg_VMValues4(SgVM * vm,SgObject v1,SgObject v2,SgObject v3,SgObject v4)381 SgObject Sg_VMValues4(SgVM *vm, SgObject v1,
382 SgObject v2, SgObject v3, SgObject v4)
383 {
384 vm->valuesCount = 4;
385 vm->values[0] = v2;
386 vm->values[1] = v3;
387 vm->values[2] = v4;
388 vm->ac = v1;
389 return v1;
390 }
391
Sg_Values5(SgObject v1,SgObject v2,SgObject v3,SgObject v4,SgObject v5)392 SgObject Sg_Values5(SgObject v1, SgObject v2, SgObject v3, SgObject v4,
393 SgObject v5)
394 {
395 return Sg_VMValues5(theVM, v1, v2, v3, v4, v5);
396 }
397
Sg_VMValues5(SgVM * vm,SgObject v1,SgObject v2,SgObject v3,SgObject v4,SgObject v5)398 SgObject Sg_VMValues5(SgVM *vm, SgObject v1,
399 SgObject v2, SgObject v3, SgObject v4, SgObject v5)
400 {
401 vm->valuesCount = 5;
402 vm->values[0] = v2;
403 vm->values[1] = v3;
404 vm->values[2] = v4;
405 vm->values[3] = v5;
406 vm->ac = v1;
407 return v1;
408 }
409
410
411 /* some flags */
412 /* bench mark said, it does not make that much difference.
413 and made call/cc so slow.
414 maybe we need to do call/cc performance tuning first.
415 */
416 #define CLEAN_STACK 1
417 /* #define PROF_INSN 1 */
418 /* #define SHOW_CALL_TRACE 1 */
419 /*
420 clear stack.
421 for now, it's only used after compile.
422 benchmark said it did not make that much difference, however it definitely
423 reduced some GC counts. well just put it.
424 */
425 #if CLEAN_STACK
426 #define CLEAR_STACK(vm) \
427 memset(SP(vm),0,((vm)->stackEnd-SP(vm))*sizeof(SgObject))
428 #else
429 #define CLEAR_STACK(vm) /* dummy */
430 #endif
431
432 static const int MAX_STACK_TRACE = 20;
433
Sg_FormatStackTrace(SgObject stackTrace,SgObject out)434 void Sg_FormatStackTrace(SgObject stackTrace, SgObject out)
435 {
436 SgObject cur;
437 SgPort *buf = SG_PORT(Sg_MakeStringOutputPort(-1));
438 Sg_Printf(buf, UC("stack trace:\n"));
439 stackTrace = Sg_Reverse(stackTrace);
440
441 SG_FOR_EACH(cur, stackTrace) {
442 SgObject obj, index, proc, tmp, src, file, info, line;
443
444 obj = SG_CAR(cur);
445 index = SG_CAR(obj);
446 if (SG_INT_VALUE(index) > MAX_STACK_TRACE) {
447 Sg_Printf(buf, UC(" ... (more stack dump truncated)\n"));
448 break;
449 }
450
451 proc = SG_CDR(obj); /* (proc name src) */
452 if (SG_EQ(SG_CAR(proc), SG_INTERN("*proc*"))) {
453 tmp = SG_CAR(SG_CDDR(proc));
454 if (!SG_PAIRP(tmp)) {
455 goto no_src;
456 } else {
457 src = Sg_LastPair(tmp);
458 src = SG_CDAR(src);
459 if (SG_PAIRP(src)) {
460 info = Sg_GetPairAnnotation(src, SG_INTERN("source-info"));
461 } else {
462 info = SG_FALSE;
463 }
464 }
465 if (SG_FALSEP(info) || !info) {
466 Sg_PrintfShared(buf,
467 UC(" [%A] %A\n"
468 " src: %#50S\n"),
469 index, SG_CADR(proc),
470 Sg_UnwrapSyntax(src));
471 } else {
472 file = SG_CAR(info);
473 line = SG_CDR(info);
474 Sg_PrintfShared(buf,
475 UC(" [%A] %A\n"
476 " src: %#50S\n"
477 " %S:%A\n"),
478 index, SG_CADR(proc),
479 Sg_UnwrapSyntax(src),
480 file, line);
481 }
482
483 } else {
484 no_src:
485 /* *cproc* does not have any source info */
486 Sg_Printf(buf,
487 UC(" [%A] %A\n"),
488 index, SG_CADR(proc));
489 }
490 }
491 }
492
493 /* we need to check pc-1(for *CALL, or os) or pc-2(for GREF_*CALL) */
get_closure_source(SgObject cl,SgWord * pc)494 static SgObject get_closure_source(SgObject cl, SgWord *pc)
495 {
496 SgCodeBuilder *cb = SG_CODE_BUILDER(SG_CLOSURE(cl)->code);
497 InsnInfo *info;
498 SgObject src = SG_FALSE;
499 intptr_t index = -1, j;
500 SgObject name = SG_PROCEDURE_NAME(cl);
501
502 if (SG_FALSEP(name)) {
503 /* try codebuilder name */
504 name = Sg_CodeBuilderFullName(cb);
505 }
506 /* before FRAME insn there must be a insn which has src info */
507 for (j = 1;; j++) {
508 if (Sg_GCBase(SG_OBJ(*(pc-j)))) continue;
509 info = Sg_LookupInsnName(INSN(*(pc-j)));
510 if (info && info->hasSrc) break;
511 }
512 /* for sanity */
513 if (info && info->hasSrc) {
514 index = (pc-j) - cb->code;
515 }
516 if (index > 0) {
517 if (SG_PAIRP(cb->src)) {
518 src = Sg_Assv(SG_MAKE_INT(index), cb->src);
519 }
520 }
521 return src;
522 }
523
format_stack_trace(SgVM * vm,SgObject buf,SgContFrame * cur,SgContFrame * prev,SgObject cl,SgWord * pc)524 static void format_stack_trace(SgVM *vm, SgObject buf, SgContFrame *cur,
525 SgContFrame *prev, SgObject cl, SgWord *pc)
526 {
527 int i;
528 SgContFrame *shared = NULL;
529
530 if (prev) {
531 SgContFrame *tmp = cur;
532 while (tmp != tmp->prev && tmp != tmp->prev->prev) {
533 SgContFrame *sharedTmp = prev;
534 while (sharedTmp != sharedTmp->prev
535 && sharedTmp != sharedTmp->prev->prev) {
536 if (tmp == sharedTmp) {
537 shared = sharedTmp;
538 break;
539 }
540 sharedTmp = sharedTmp->prev;
541 }
542 if (shared) break;
543 tmp = tmp->prev;
544 }
545 }
546
547 Sg_PutuzUnsafe(buf, UC("stack trace:\n"));
548 for (i = 1;;) {
549 if (i > MAX_STACK_TRACE) {
550 Sg_PutuzUnsafe(buf, UC(" ... (more stack dump truncated)\n"));
551 return;
552 }
553
554 if (SG_SUBRP(cl)) {
555 /* useless to show */
556 if (SG_FALSEP(SG_PROCEDURE_NAME(cl))) goto next_frame;
557 Sg_Printf(buf, UC(" [%d] %A\n"), i, SG_PROCEDURE_NAME(cl));
558 } else if (SG_CLOSUREP(cl)) {
559 SgObject name = SG_PROCEDURE_NAME(cl);
560 if (SG_CLOSURE(cl)->code
561 && SG_CODE_BUILDERP(SG_CLOSURE(cl)->code)) {
562 SgObject src = get_closure_source(cl, pc), info = SG_FALSE;;
563
564 if (SG_FALSEP(src)) goto no_src_info;
565 src = SG_CDR(src);
566 if (SG_PAIRP(src)) {
567 info = Sg_GetPairAnnotation(src, SG_INTERN("source-info"));
568 }
569 if (SG_FALSEP(info) || !info) {
570 Sg_PrintfShared(buf, UC(" [%d] %A\n"
571 " src: %#50S\n"),
572 i, name,
573 Sg_UnwrapSyntax(src));
574 } else {
575 Sg_PrintfShared(buf,
576 UC(" [%d] %A\n"
577 " src: %#50S\n"
578 " %S:%A\n"),
579 i, name, Sg_UnwrapSyntax(src),
580 SG_CAR(info), SG_CDR(info));
581 }
582 } else {
583 no_src_info:
584 /* Should we show address and pointer? */
585 if (SG_FALSEP(name)) goto next_frame; /* useless to show */
586 Sg_Printf(buf, UC(" [%d] %A\n"), i, name);
587 }
588 }
589 i++;
590 next_frame:
591 /* next frame */
592 if ((!IN_STACK_P((SgObject *)cur, vm) ||
593 (uintptr_t)cur > (uintptr_t)vm->stack) &&
594 /* already printed */
595 cur != shared) {
596 cl = cur->cl;
597 pc = cur->pc;
598 cur = cur->prev;
599
600 if (!SG_PTRP(cur)) return;
601 /* invalid cur frame */
602 if (IN_STACK_P((SgObject *)cur, vm) &&
603 ((uintptr_t)cur < (uintptr_t)vm->stack ||
604 (uintptr_t)vm->stackEnd < (uintptr_t)cur)) {
605 break;
606 }
607 if (!cl) return;
608 if (!SG_PROCEDUREP(cl)) return;
609 } else {
610 return;
611 }
612 }
613 }
614
615
report_error(SgObject error,SgObject out)616 static inline void report_error(SgObject error, SgObject out)
617 {
618 SgObject next = SG_FALSE, cl;
619 SgPort *buf = SG_PORT(Sg_MakeStringOutputPort(-1));
620 SgContFrame *stackTrace = NULL;
621 SgWord *pc;
622
623 if (Sg_ConditionP(error)) {
624 if (Sg_CompoundConditionP(error)) {
625 SgObject cp;
626 SG_FOR_EACH(cp, Sg_CompoundConditionComponent(error)) {
627 if (SG_STACK_TRACE_CONDITION_P(SG_CAR(cp))) {
628 stackTrace
629 = (SgContFrame *)SG_STACK_TRACE_CONDITION(SG_CAR(cp))->trace;
630 next = SG_STACK_TRACE_CONDITION(SG_CAR(cp))->cause;
631 cl = SG_STACK_TRACE_CONDITION(SG_CAR(cp))->cl;
632 pc = SG_STACK_TRACE_CONDITION(SG_CAR(cp))->pc;
633 break;
634 }
635 }
636 } else if (SG_STACK_TRACE_CONDITION_P(error)) {
637 stackTrace = (SgContFrame *)SG_STACK_TRACE_CONDITION(error)->trace;
638 next = SG_STACK_TRACE_CONDITION(error)->cause;
639 cl = SG_STACK_TRACE_CONDITION(error)->cl;
640 pc = SG_STACK_TRACE_CONDITION(error)->pc;
641 }
642 }
643 if (!stackTrace) {
644 SgVM *vm = Sg_VM();
645 stackTrace = CONT(vm);
646 cl = CL(vm);
647 pc = PC(vm);
648 }
649 Sg_Printf(buf,
650 UC("Unhandled exception\n"
651 " %A\n"), Sg_DescribeCondition(error));
652
653 if (cl && !SG_NULLP(stackTrace)) {
654 SgVM *vm = Sg_VM();
655 SgContFrame *prevFrame = NULL;
656 while (1) {
657 format_stack_trace(vm, buf, stackTrace, prevFrame, cl, pc);
658 if (SG_STACK_TRACE_CONDITION_P(next)) {
659 prevFrame = stackTrace;
660 stackTrace = (SgContFrame *)SG_STACK_TRACE_CONDITION(next)->trace;
661 next = SG_STACK_TRACE_CONDITION(next)->cause;
662 if (SG_STACK_TRACE_CONDITION_P(next)) {
663 cl = SG_STACK_TRACE_CONDITION(next)->cl;
664 pc = SG_STACK_TRACE_CONDITION(next)->pc;
665 }
666 Sg_PutuzUnsafe(buf, UC("Nested "));
667 } else {
668 break;
669 }
670 }
671 }
672 /* for some reason, certain Windows platform failed to create
673 stdout, at that moment, there is no stderr ready so out might
674 be NULL.
675 NB: in the case, it's an unrecoverable error, so just dump
676 native stack trace.*/
677 Sg_Write(Sg_GetStringFromStringPort(SG_STRING_PORT(buf)),
678 out, SG_WRITE_DISPLAY);
679 Sg_FlushAllPort(FALSE);
680 }
681
Sg_ReportError(SgObject e,SgObject out)682 void Sg_ReportError(SgObject e, SgObject out)
683 {
684 report_error(e, out);
685 }
686
Sg_ReportErrorInternal(volatile SgObject e,SgObject out)687 void Sg_ReportErrorInternal(volatile SgObject e, SgObject out)
688 {
689 SgVM *vm = Sg_VM();
690
691 if (SG_VM_RUNTIME_FLAG_IS_SET(vm, SG_ERROR_BEING_REPORTED)) {
692 Sg_Abort("Unhandled error occurred during reporting an error."
693 " Process aborted.\n");
694 }
695 SG_VM_RUNTIME_FLAG_SET(vm, SG_ERROR_BEING_REPORTED);
696 SG_UNWIND_PROTECT {
697 if (Sg_MainThreadP()) {
698 Sg_FlushAllPort(FALSE);
699 Sg_ReportError(e, out);
700 }
701 }
702 SG_WHEN_ERROR {
703 SG_VM_RUNTIME_FLAG_CLEAR(vm, SG_ERROR_BEING_REPORTED);
704 }
705 SG_END_PROTECT;
706 SG_VM_RUNTIME_FLAG_CLEAR(vm, SG_ERROR_BEING_REPORTED);
707 }
708
vm_dump_code_rec(SgCodeBuilder * cb,int indent)709 static void vm_dump_code_rec(SgCodeBuilder *cb, int indent)
710 {
711 SgVM *vm = Sg_VM();
712 int i, size = cb->size, ind;
713 InsnInfo *info;
714 SgWord *code = cb->code;
715
716 #define write_indent() \
717 Sg_Write(SG_MAKE_STRING(";; "), vm->logPort, SG_WRITE_DISPLAY); \
718 for (ind = 0; ind < indent; ind++) { \
719 Sg_Write(SG_MAKE_CHAR(' '), vm->logPort, SG_WRITE_DISPLAY); \
720 }
721
722 write_indent();
723 Sg_Printf(vm->logPort, UC("size: %d\n"), size);
724 for (i = 0; i < size;) {
725 int need_line_break = TRUE;
726 SgObject s;
727 SgPort *out = SG_PORT(Sg_MakeStringOutputPort(-1));
728 info = Sg_LookupInsnName(INSN(code[i]));
729
730 write_indent();
731 Sg_Printf(out, UC("%4d: %A"), i, Sg_MakeStringC(info->name));
732 if (info->instValues != 0) {
733 int val1, val2;
734 switch (info->instValues) {
735 case 1:
736 INSN_VAL1(val1, code[i]);
737 Sg_Printf(out, UC("(%d)"), val1);
738 break;
739 case 2:
740 INSN_VAL2(val1, val2, code[i]);
741 Sg_Printf(out, UC("(%d %d)"), val1, val2);
742 }
743 }
744 if (info->argc != 0) {
745 /* for now insn argument is only one */
746 SgObject arg = SG_OBJ(code[i + 1]);
747 if (!info->label && SG_CODE_BUILDERP(arg)) {
748 s = Sg_GetStringFromStringPort(SG_STRING_PORT(out));
749 Sg_Puts(vm->logPort, SG_STRING(s));
750 Sg_Printf(vm->logPort, UC(" %S\n"), arg);
751 vm_dump_code_rec(SG_CODE_BUILDER(arg), indent + 2);
752 need_line_break = FALSE;
753 } else {
754 if (info->label) Sg_Printf(out, UC(" %d"), arg);
755 else Sg_Printf(out, UC(" %#S"), arg);
756 s = Sg_GetStringFromStringPort(SG_STRING_PORT(out));
757 Sg_Puts(vm->logPort, SG_STRING(s));
758 if (info->hasSrc) {
759 if (SG_PAIRP(cb->src)) {
760 SgObject src = Sg_Assv(SG_MAKE_INT(i), cb->src);
761 long len = SG_STRING_SIZE(s);
762 for (; len<32; len++) {
763 Sg_Putc(vm->logPort, ' ');
764 }
765 if (!SG_FALSEP(src)) {
766 Sg_Printf(vm->logPort, UC("; %#30.1S"),
767 Sg_UnwrapSyntax(SG_CDR(src)));
768 }
769 }
770 }
771 }
772 } else {
773 s = Sg_GetStringFromStringPort(SG_STRING_PORT(out));
774 Sg_Puts(vm->logPort, SG_STRING(s));
775 }
776 if (need_line_break) {
777 Sg_Printf(vm->logPort, UC("\n"));
778 }
779 i += 1 + info->argc;
780 }
781 }
782
Sg_VMDumpCode(SgCodeBuilder * cb)783 void Sg_VMDumpCode(SgCodeBuilder *cb)
784 {
785 vm_dump_code_rec(cb, 0);
786 }
787
Sg_CurrentOutputPort()788 SgObject Sg_CurrentOutputPort()
789 {
790 SgVM *vm = Sg_VM();
791 return vm->currentOutputPort;
792 }
793
Sg_CurrentErrorPort()794 SgObject Sg_CurrentErrorPort()
795 {
796 SgVM *vm = Sg_VM();
797 return vm->currentErrorPort;
798 }
799
Sg_CurrentInputPort()800 SgObject Sg_CurrentInputPort()
801 {
802 SgVM *vm = Sg_VM();
803 return vm->currentInputPort;
804 }
805
Sg_VMCurrentLibrary()806 SgObject Sg_VMCurrentLibrary()
807 {
808 return Sg_VM()->currentLibrary;
809 }
810
811
Sg_EnableSandbox()812 void Sg_EnableSandbox()
813 {
814 SgVM *vm = Sg_VM();
815 if (SG_FALSEP(vm->sandbox)) {
816 vm->sandbox = Sg_MakeHashTableSimple(SG_HASH_EQUAL, 32);
817 }
818 }
Sg_DisableSandbox()819 void Sg_DisableSandbox()
820 {
821 SgVM *vm = Sg_VM();
822 vm->sandbox = SG_FALSE;
823 }
824
825
Sg_VMAcquireGlobalLock()826 void Sg_VMAcquireGlobalLock()
827 {
828 Sg_LockMutex(&global_lock);
829 }
830
Sg_VMReleaseGlobalLock()831 void Sg_VMReleaseGlobalLock()
832 {
833 Sg_UnlockMutex(&global_lock);
834 }
835
836 static SgObject compiler = SG_UNDEF;
init_compiler()837 static void init_compiler()
838 {
839 SgObject compile_library;
840 SgGloc *g;
841 Sg_LockMutex(&global_lock);
842 compile_library=Sg_FindLibrary(SG_INTERN("(sagittarius compiler)"), FALSE);
843 g = Sg_FindBinding(compile_library, SG_INTERN("compile"), SG_FALSE);
844 compiler = SG_GLOC_GET(g);
845 Sg_UnlockMutex(&global_lock);
846 }
847
848 /* compiler */
849 #define define_compiler(name, apply) \
850 SgObject SG_CPP_CAT(Sg_, name)(SgObject o, SgObject e) \
851 { \
852 /* compiler is initialized after VM. so we need to \
853 look it up first */ \
854 if (SG_UNDEFP(compiler)) { \
855 init_compiler(); \
856 } \
857 return apply(compiler, o, e); \
858 }
define_compiler(Compile,Sg_Apply2)859 define_compiler(Compile, Sg_Apply2)
860 define_compiler(VMCompile, Sg_VMApply2)
861 /*
862 env: library for now.
863 */
864 SgObject Sg_Eval(SgObject sexp, SgObject env)
865 {
866 SgObject v = SG_NIL, c;
867 SgVM *vm = theVM;
868 SgObject r = SG_UNDEF, save = vm->currentLibrary;
869
870 if (vm->state != IMPORTING) vm->state = COMPILING;
871 v = Sg_Compile(sexp, env);
872 /* store cache */
873 if (vm->state == IMPORTING) SG_SET_CAR(vm->cache, Sg_Cons(v, SG_CAR(vm->cache)));
874 if (vm->state != IMPORTING) vm->state = RUNNING;
875
876 ASSERT(SG_CODE_BUILDERP(v));
877 if (SG_VM_LOG_LEVEL(vm, SG_DEBUG_LEVEL)) {
878 Sg_VMDumpCode(v);
879 }
880 if (!SG_FALSEP(env)) {
881 vm->currentLibrary = env;
882 }
883 c = Sg_MakeClosure(v, NULL);
884 r = evaluate_safe(c, SG_CODE_BUILDER(v)->code);
885 vm->currentLibrary = save;
886 return r;
887 }
888
eval_restore_env(SgObject * args,int argc,void * data)889 static SgObject eval_restore_env(SgObject *args, int argc, void *data)
890 {
891 theVM->currentLibrary = SG_LIBRARY(data);
892 return SG_UNDEF;
893 }
894
next_eval_cc(SgObject v,void ** data)895 static SgObject next_eval_cc(SgObject v, void **data)
896 {
897 SgObject body, before, after, env = data[0];
898 SgVM *vm = theVM;
899 /* Now we are checking with this defined variable during compilation,
900 and if a macro have eval in it blow resets the defined variables.
901 to avoid it we need to keep it. */
902 /* SG_LIBRARY_DEFINEED(vm->currentLibrary) = SG_NIL; */
903 /* store cache */
904 if (vm->state == IMPORTING) {
905 SG_SET_CAR(vm->cache, Sg_Cons(v, SG_CAR(vm->cache)));
906 }
907 if (vm->state != IMPORTING) vm->state = RUNNING;
908 CLEAR_STACK(vm);
909
910 /* ASSERT(SG_CODE_BUILDERP(v)); */
911 if (SG_VM_LOG_LEVEL(vm, SG_DEBUG_LEVEL)) {
912 Sg_VMDumpCode(v);
913 }
914 vm->valuesCount = 1;
915
916 body = Sg_MakeClosure(v, NULL);
917 if (!SG_FALSEP(env)) {
918 before = Sg_MakeSubr(eval_restore_env, env, 0, 0, SG_FALSE);
919 } else {
920 before = Sg_NullProc();
921 }
922 after = Sg_MakeSubr(eval_restore_env, vm->currentLibrary, 0, 0, SG_FALSE);
923 return Sg_VMDynamicWind(before, body, after);
924 }
925
Sg_VMEval(SgObject sexp,SgObject env)926 SgObject Sg_VMEval(SgObject sexp, SgObject env)
927 {
928 SgVM *vm = theVM;
929 void *data[1];
930 data[0] = env;
931 Sg_VMPushCC(next_eval_cc, data, 1);
932 if (vm->state != IMPORTING) vm->state = COMPILING;
933 return Sg_VMCompile(sexp, env);
934 }
935
936 static SgObject pass1_import = SG_UNDEF;
937
init_pass1_import()938 static void init_pass1_import()
939 {
940 SgLibrary *complib;
941 SgGloc *g;
942 Sg_LockMutex(&global_lock);
943 complib = Sg_FindLibrary(SG_INTERN("(sagittarius compiler)"), FALSE);
944 g = Sg_FindBinding(complib, SG_INTERN("pass1/import"), SG_UNBOUND);
945 if (SG_UNBOUNDP(g)) {
946 /* something wrong */
947 Sg_Panic("pass1/import was not found. loading error?");
948 }
949 pass1_import = SG_GLOC_GET(g);
950 Sg_UnlockMutex(&global_lock);
951 }
952
953 /* well this is actually not used, and i don't think will ever be used
954 but in case... */
Sg_Environment(SgObject lib,SgObject spec)955 SgObject Sg_Environment(SgObject lib, SgObject spec)
956 {
957 if (SG_UNDEFP(pass1_import)) {
958 init_pass1_import();
959 }
960 /* make spec look like import-spec */
961 spec = Sg_Cons(SG_INTERN("import"), spec);
962 Sg_Apply2(pass1_import, spec, lib);
963 return lib;
964 }
965
environment_cc(SgObject result,void ** data)966 static SgObject environment_cc(SgObject result, void **data)
967 {
968 return SG_OBJ(data[0]);
969 }
970
Sg_VMEnvironment(SgObject lib,SgObject spec)971 SgObject Sg_VMEnvironment(SgObject lib, SgObject spec)
972 {
973 void *data[1];
974 if (SG_UNDEFP(pass1_import)) {
975 init_pass1_import();
976 }
977 /* make spec look like import-spec */
978 spec = Sg_Cons(SG_INTERN("import"), spec);
979 data[0] = lib;
980 Sg_VMPushCC(environment_cc, data, 1);
981 return Sg_VMApply2(pass1_import, spec, lib);
982 }
983
984 static void print_frames(SgVM *vm, SgContFrame *cont);
985 static void expand_stack(SgVM *vm);
986
987 /* it does not improve performance */
988 /* #ifdef __GNUC__ */
989 #if 0
990 #define MOSTLY_FALSE(expr) __builtin_expect(!!(expr), FALSE)
991 #else
992 #define MOSTLY_FALSE(expr) expr
993 #endif
994
995 #define CHECK_STACK(size, vm) \
996 do { \
997 if (MOSTLY_FALSE(SP(vm) >= (vm)->stackEnd - (size))) { \
998 expand_stack(vm); \
999 } \
1000 } while (0)
1001
1002 #define C_CONT_MARK NULL
1003
Sg_VMPushCC(SgCContinuationProc * after,void ** data,int datasize)1004 void Sg_VMPushCC(SgCContinuationProc *after, void **data, int datasize)
1005 {
1006 int i;
1007 SgContFrame *cc;
1008 SgObject *s;
1009 SgVM *vm = Sg_VM();
1010
1011 CHECK_STACK(CONT_FRAME_SIZE + datasize, vm);
1012 s = SP(vm);
1013 cc = (SgContFrame*)s;
1014 s += CONT_FRAME_SIZE;
1015 cc->prev = CONT(vm);
1016 cc->size = datasize;
1017 cc->pc = (SgWord*)after;
1018 cc->fp = C_CONT_MARK;
1019 cc->cl = CL(vm);
1020 for (i = 0; i < datasize; i++) {
1021 PUSH(s, SG_OBJ(data[i]));
1022 }
1023 CONT(vm) = cc;
1024 FP(vm) = SP(vm) = s;
1025 }
1026
1027 /* #define USE_LIGHT_WEIGHT_APPLY 1 */
1028
1029 #define PUSH_CONT(vm, next_pc) \
1030 do { \
1031 SgContFrame *newcont = (SgContFrame*)SP(vm); \
1032 newcont->prev = CONT(vm); \
1033 newcont->size = (int)(SP(vm) - FP(vm)); \
1034 newcont->pc = next_pc; \
1035 newcont->cl = CL(vm); \
1036 newcont->fp = FP(vm); \
1037 CONT(vm) = newcont; \
1038 SP(vm) += CONT_FRAME_SIZE; \
1039 } while (0)
1040
1041
1042 static SgWord apply_callN[2] = {
1043 MERGE_INSN_VALUE2(APPLY, 2, 1),
1044 RET
1045 };
1046
1047 static SgWord apply_calls[][5] = {
1048 { MERGE_INSN_VALUE1(TAIL_CALL, 0), RET },
1049 { MERGE_INSN_VALUE1(TAIL_CALL, 1), RET },
1050 { MERGE_INSN_VALUE1(TAIL_CALL, 2), RET },
1051 { MERGE_INSN_VALUE1(TAIL_CALL, 3), RET },
1052 { MERGE_INSN_VALUE1(TAIL_CALL, 4), RET }
1053 };
1054
1055 /* dummy closure */
1056 static SgClosure internal_toplevel_closure =
1057 { SG__PROCEDURE_INITIALIZER(SG_CLASS_STATIC_TAG(Sg_ProcedureClass),
1058 0, 0, SG_PROC_CLOSURE, SG_FALSE, SG_FALSE),
1059 SG_FALSE,};
1060
apply_rec(SgVM * vm,SgObject proc,SgObject rest,int nargs)1061 static SgObject apply_rec(SgVM *vm, SgObject proc, SgObject rest, int nargs)
1062 {
1063 SgObject program;
1064 SgWord code[3];
1065 code[0] = SG_WORD(MERGE_INSN_VALUE1(APPLY_VALUES, nargs));
1066 code[1] = SG_WORD(rest);
1067 code[2] = SG_WORD(RET);
1068
1069 AC(vm) = proc;
1070 program = (CL(vm)) ? CL(vm) : SG_OBJ(&internal_toplevel_closure);
1071 return evaluate_safe(program, code);
1072 }
1073
1074
Sg_Apply0(SgObject proc)1075 SgObject Sg_Apply0(SgObject proc)
1076 {
1077 return apply_rec(theVM, proc, SG_NIL, 0);
1078 }
1079
Sg_Apply1(SgObject proc,SgObject arg)1080 SgObject Sg_Apply1(SgObject proc, SgObject arg)
1081 {
1082 SgVM *vm = theVM;
1083 vm->values[0] = arg;
1084 return apply_rec(theVM, proc, SG_NIL, 1);
1085 }
1086
Sg_Apply2(SgObject proc,SgObject arg0,SgObject arg1)1087 SgObject Sg_Apply2(SgObject proc, SgObject arg0, SgObject arg1)
1088 {
1089 SgVM *vm = theVM;
1090 vm->values[0] = arg0;
1091 vm->values[1] = arg1;
1092 return apply_rec(theVM, proc, SG_NIL, 2);
1093 }
1094
Sg_Apply3(SgObject proc,SgObject arg0,SgObject arg1,SgObject arg2)1095 SgObject Sg_Apply3(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2)
1096 {
1097 SgVM *vm = theVM;
1098 vm->values[0] = arg0;
1099 vm->values[1] = arg1;
1100 vm->values[2] = arg2;
1101 return apply_rec(theVM, proc, SG_NIL, 3);
1102 }
1103
Sg_Apply4(SgObject proc,SgObject arg0,SgObject arg1,SgObject arg2,SgObject arg3)1104 SgObject Sg_Apply4(SgObject proc, SgObject arg0, SgObject arg1,
1105 SgObject arg2, SgObject arg3)
1106 {
1107 SgVM *vm = theVM;
1108 vm->values[0] = arg0;
1109 vm->values[1] = arg1;
1110 vm->values[2] = arg2;
1111 vm->values[3] = arg3;
1112 return apply_rec(theVM, proc, SG_NIL, 4);
1113 }
1114
Sg_Apply(SgObject proc,SgObject args)1115 SgObject Sg_Apply(SgObject proc, SgObject args)
1116 {
1117 SgVM *vm = theVM;
1118 int nargs = (int)Sg_Length(args), i;
1119 if (nargs < 0) {
1120 Sg_Error(UC("improper list not allowed: %S"), args);
1121 }
1122
1123 for (i = 0; i < nargs; i++) {
1124 if (i == DEFAULT_VALUES_SIZE) break;
1125 vm->values[i] = SG_CAR(args);
1126 args = SG_CDR(args);
1127 }
1128 return apply_rec(vm, proc, args, nargs);
1129 }
1130
1131 /*
1132 VMApply families.
1133
1134 NB: make sure before call these functions, we need to call Sg_VMPushCC.
1135 */
Sg_VMApply(SgObject proc,SgObject args)1136 SgObject Sg_VMApply(SgObject proc, SgObject args)
1137 {
1138 int argc = (int)Sg_Length(args);
1139 int reqstack;
1140 SgVM *vm = Sg_VM();
1141
1142 if (argc < 0) Sg_Error(UC("improper list not allowed: %S"), args);
1143 /* TODO should we check tail posision? */
1144 reqstack = SG_FRAME_SIZE + 1;
1145 CHECK_STACK(reqstack, vm);
1146 PUSH(SP(vm), proc);
1147 PC(vm) = apply_callN;
1148 /* return Sg_CopyList(args); */
1149 return Sg_CopyList(args);;
1150 }
1151
Sg_VMApply0(SgObject proc)1152 SgObject Sg_VMApply0(SgObject proc)
1153 {
1154 Sg_VM()->pc = apply_calls[0];
1155 return proc;
1156 }
1157
Sg_VMApply1(SgObject proc,SgObject arg)1158 SgObject Sg_VMApply1(SgObject proc, SgObject arg)
1159 {
1160 SgVM *vm = Sg_VM();
1161 CHECK_STACK(1, vm);
1162 PUSH(SP(vm), arg);
1163 vm->pc = apply_calls[1];
1164 return proc;
1165 }
1166
Sg_VMApply2(SgObject proc,SgObject arg0,SgObject arg1)1167 SgObject Sg_VMApply2(SgObject proc, SgObject arg0, SgObject arg1)
1168 {
1169 SgVM *vm = Sg_VM();
1170 CHECK_STACK(2, vm);
1171 PUSH(SP(vm), arg0);
1172 PUSH(SP(vm), arg1);
1173 vm->pc = apply_calls[2];
1174 return proc;
1175 }
1176
Sg_VMApply3(SgObject proc,SgObject arg0,SgObject arg1,SgObject arg2)1177 SgObject Sg_VMApply3(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2)
1178 {
1179 SgVM *vm = Sg_VM();
1180 CHECK_STACK(3, vm);
1181 PUSH(SP(vm), arg0);
1182 PUSH(SP(vm), arg1);
1183 PUSH(SP(vm), arg2);
1184 vm->pc = apply_calls[3];
1185 return proc;
1186 }
1187
Sg_VMApply4(SgObject proc,SgObject arg0,SgObject arg1,SgObject arg2,SgObject arg3)1188 SgObject Sg_VMApply4(SgObject proc, SgObject arg0, SgObject arg1, SgObject arg2, SgObject arg3)
1189 {
1190 SgVM *vm = Sg_VM();
1191 CHECK_STACK(4, vm);
1192 PUSH(SP(vm), arg0);
1193 PUSH(SP(vm), arg1);
1194 PUSH(SP(vm), arg2);
1195 PUSH(SP(vm), arg3);
1196 vm->pc = apply_calls[4];
1197 return proc;
1198 }
1199
1200 /*
1201 dynamic-wind
1202 memo:
1203 about cont(call) frame.
1204 in sagittarius scheme, a call frame and cont frame are the same. we push
1205 call/cont frame when closure was called and dynamic-wind was called. the
1206 structure of call/cont frame is like this:
1207 +-----------+ <- sp
1208 | arg 0 - n |
1209 +-----------+ <- current fp
1210 | size |
1211 | fp | the order of frame structure does not matter(see vm.h)
1212 | cl |
1213 | dc |
1214 | pc |
1215 | prev |
1216 +-----------+
1217 the difference between Sg_VMPushCC and make_call_frame is how to treat
1218 fp when a frame was made and size. Sg_VMPushCC sets fp when it's called but,
1219 make_call_frame does not.
1220 */
1221 static SgCContinuationProc dynamic_wind_before_cc;
1222 static SgCContinuationProc dynamic_wind_body_cc;
1223 static SgCContinuationProc dynamic_wind_after_cc;
1224
Sg_VMDynamicWind(SgObject before,SgObject thunk,SgObject after)1225 SgObject Sg_VMDynamicWind(SgObject before, SgObject thunk, SgObject after)
1226 {
1227 void *data[3];
1228 /* TODO should we check type? */
1229 data[0] = (void*)before;
1230 data[1] = (void*)thunk;
1231 data[2] = (void*)after;
1232
1233 Sg_VMPushCC(dynamic_wind_before_cc, data, 3);
1234 return Sg_VMApply0(before);
1235 }
1236
dynamic_wind_before_cc(SgObject result,void ** data)1237 static SgObject dynamic_wind_before_cc(SgObject result, void **data)
1238 {
1239 SgObject before = SG_OBJ(data[0]);
1240 SgObject body = SG_OBJ(data[1]);
1241 SgObject after = SG_OBJ(data[2]);
1242 SgObject prev;
1243 void *d[2];
1244 SgVM *vm = Sg_VM();
1245
1246 prev = vm->dynamicWinders;
1247 d[0] = (void*)after;
1248 d[1] = (void*)prev;
1249 vm->dynamicWinders = Sg_Acons(before, after, prev);
1250 Sg_VMPushCC(dynamic_wind_body_cc, d, 2);
1251 return Sg_VMApply0(body);
1252 }
1253
dynamic_wind_body_cc(SgObject result,void ** data)1254 static SgObject dynamic_wind_body_cc(SgObject result, void **data)
1255 {
1256 SgObject after = SG_OBJ(data[0]);
1257 SgObject prev = SG_OBJ(data[1]);
1258 void *d[3];
1259 SgVM *vm = Sg_VM();
1260
1261 vm->dynamicWinders = prev;
1262 d[0] = (void*)result;
1263 d[1] = (void*)(intptr_t)vm->valuesCount;
1264 if (vm->valuesCount > 1) {
1265 SgObject *array = SG_NEW_ARRAY(SgObject, vm->valuesCount - 1);
1266 int i;
1267 for (i = 0; i < vm->valuesCount-1; i++) {
1268 array[i] = SG_VALUES_REF(vm, i);
1269 }
1270 d[2] = array;
1271 } else {
1272 d[2] = NULL;
1273 }
1274 Sg_VMPushCC(dynamic_wind_after_cc, d, 3);
1275 return Sg_VMApply0(after);
1276 }
1277
dynamic_wind_after_cc(SgObject result,void ** data)1278 static SgObject dynamic_wind_after_cc(SgObject result, void **data)
1279 {
1280 SgObject ac = SG_OBJ(data[0]);
1281 int nvals = (int)(intptr_t)(data[1]);
1282 SgVM *vm = theVM;
1283 vm->valuesCount = nvals;
1284 if (nvals > 1) {
1285 int i;
1286 SgObject *array = (SgObject*)data[2];
1287 for (i = 0; i < nvals-1; i++) {
1288 SG_VALUES_SET(vm, i, array[i]);
1289 }
1290 }
1291 return ac;
1292 }
1293
Sg_VMDynamicWindC(SgSubrProc * before,SgSubrProc * body,SgSubrProc * after,void * data)1294 SgObject Sg_VMDynamicWindC(SgSubrProc *before,
1295 SgSubrProc *body,
1296 SgSubrProc *after,
1297 void *data)
1298 {
1299 SgObject beforeproc, bodyproc, afterproc;
1300 beforeproc = before ? Sg_MakeSubr(before, data, 0, 0, SG_FALSE) : Sg_NullProc();
1301 bodyproc = body ? Sg_MakeSubr(body, data, 0, 0, SG_FALSE) : Sg_NullProc();
1302 afterproc = after ? Sg_MakeSubr(after, data, 0, 0, SG_FALSE) : Sg_NullProc();
1303 return Sg_VMDynamicWind(beforeproc, bodyproc, afterproc);
1304 }
1305
install_ehandler(SgObject * args,int argc,void * data)1306 static SgObject install_ehandler(SgObject *args, int argc, void *data)
1307 {
1308 SgContinuation *c = (SgContinuation*)data;
1309 SgVM *vm = Sg_VM();
1310 vm->exceptionHandlers = DEFAULT_EXCEPTION_HANDLER;
1311 vm->escapePoint = c;
1312 SG_VM_RUNTIME_FLAG_CLEAR(vm, SG_ERROR_BEING_REPORTED);
1313 return SG_UNDEF;
1314 }
1315
discard_ehandler(SgObject * args,int argc,void * data)1316 static SgObject discard_ehandler(SgObject *args, int argc, void *data)
1317 {
1318 SgContinuation *c = (SgContinuation*)data;
1319 SgVM *vm = Sg_VM();
1320 vm->escapePoint = c->prev;
1321 vm->exceptionHandlers = c->xhandler;
1322 if (c->errorReporting) {
1323 SG_VM_RUNTIME_FLAG_SET(vm, SG_ERROR_BEING_REPORTED);
1324 }
1325 return SG_UNDEF;
1326 }
1327
Sg_VMWithErrorHandler(SgObject handler,SgObject thunk,int rewindBefore)1328 SgObject Sg_VMWithErrorHandler(SgObject handler, SgObject thunk,
1329 int rewindBefore)
1330 {
1331 SgContinuation *c = SG_NEW(SgContinuation);
1332 SgObject before, after;
1333 SgVM *vm = Sg_VM();
1334
1335 c->prev = vm->escapePoint;
1336 c->ehandler = handler;
1337 c->xhandler = vm->exceptionHandlers;
1338 c->winders = vm->dynamicWinders;
1339 c->cstack = vm->cstack;
1340 c->cont = vm->cont;
1341 c->floating = SG_VM_FLOATING_EP(vm);
1342 c->errorReporting = SG_VM_RUNTIME_FLAG_IS_SET(vm, SG_ERROR_BEING_REPORTED);
1343 c->rewindBefore = rewindBefore;
1344
1345 before = Sg_MakeSubr(install_ehandler, c, 0, 0, SG_FALSE);
1346 after = Sg_MakeSubr(discard_ehandler, c, 0, 0, SG_FALSE);
1347 return Sg_VMDynamicWind(before, thunk, after);
1348 }
1349
1350 static SgWord boundaryFrameMark = NOP;
1351 #define BOUNDARY_FRAME_MARK_P(cont) ((cont)->pc == &boundaryFrameMark)
1352
1353 #define FORWARDED_CONT_P(c) ((c)&&((c)->size == -1))
1354 #define FORWARDED_CONT(c) ((c)->prev)
1355
1356 /*
1357 save a cont frame with its arguments.
1358 */
save_a_cont(SgContFrame * c)1359 static SgContFrame* save_a_cont(SgContFrame *c)
1360 {
1361 SgObject *s, *d;
1362 int i;
1363 const size_t argsize = (c->size > 0) ? (c->size * sizeof(SgObject)) : 0;
1364 const size_t size = sizeof(SgContFrame) + argsize;
1365 SgContFrame *csave = SG_NEW2(SgContFrame *, size);
1366
1367 /* copy cont frame */
1368 if (c->fp != C_CONT_MARK) {
1369 *csave = *c; /* copy the frame */
1370 if (c->size > 0) {
1371 /* copy the args */
1372 s = (SgObject*)c - c->size;
1373 d = csave->env;
1374 for (i = 0; i < c->size; i++) {
1375 *d++ = *s++;
1376 }
1377 }
1378 } else {
1379 /* C continuation */
1380 s = (SgObject*)c;
1381 d = (SgObject*)csave;
1382 for (i = CONT_FRAME_SIZE + c->size; i > 0; i--) {
1383 /* C continuation frame contains opaque pointer */
1384 *d++ = *s++;
1385 }
1386 }
1387 return csave;
1388 }
1389
1390 /*
1391 save continuation frame to heap.
1392 we do with 2 passes.
1393 pass1: save cont frame to heap
1394 pass2: update cstack etc.
1395 */
save_cont_rec(SgVM * vm,int partialP)1396 static void save_cont_rec(SgVM *vm, int partialP)
1397 {
1398 SgContFrame *c = CONT(vm), *prev = NULL;
1399 SgCStack *cstk;
1400 SgContinuation *ep;
1401
1402 if (!IN_STACK_P((SgObject*)c, vm)) return;
1403
1404 do {
1405 SgContFrame *csave, *tmp;
1406 if (partialP && BOUNDARY_FRAME_MARK_P(c)) break;
1407 csave = save_a_cont(c);
1408 /* make the orig frame forwarded */
1409 if (prev) prev->prev = csave;
1410
1411 prev = csave;
1412 tmp = c->prev;
1413 c->prev = csave;
1414 c->size = -1;
1415 c = tmp;
1416 } while (IN_STACK_P((SgObject*)c, vm));
1417
1418 if (FORWARDED_CONT_P(vm->cont)) {
1419 vm->cont = FORWARDED_CONT(vm->cont);
1420 }
1421 for (cstk = vm->cstack; cstk; cstk = cstk->prev) {
1422 if (FORWARDED_CONT_P(cstk->cont)) {
1423 cstk->cont = FORWARDED_CONT(cstk->cont);
1424 }
1425 }
1426 for (ep = vm->escapePoint; ep; ep = ep->prev) {
1427 if (FORWARDED_CONT_P(ep->cont)) {
1428 ep->cont = FORWARDED_CONT(ep->cont);
1429 }
1430 }
1431 for (ep = SG_VM_FLOATING_EP(vm); ep; ep = ep->floating) {
1432 if (FORWARDED_CONT_P(ep->cont)) {
1433 ep->cont = FORWARDED_CONT(ep->cont);
1434 }
1435 }
1436 }
1437
save_cont(SgVM * vm)1438 static void save_cont(SgVM *vm)
1439 {
1440 save_cont_rec(vm, FALSE);
1441 }
1442
save_partial_cont(SgVM * vm)1443 static void save_partial_cont(SgVM *vm)
1444 {
1445 save_cont_rec(vm, TRUE);
1446 }
1447
expand_stack(SgVM * vm)1448 static void expand_stack(SgVM *vm)
1449 {
1450 SgObject *p;
1451 int i, size;
1452
1453 if (SG_VM_LOG_LEVEL(vm, SG_WARN_LEVEL)) {
1454 Sg_Printf(vm->logPort,
1455 UC(";; expanding stack in %S of %S (fp=%d, sp=%d)\n"),
1456 CL(vm), vm, FP(vm) - vm->stack, SP(vm) - vm->stack);
1457 }
1458
1459 save_cont(vm);
1460 /* seems this is a bit faster (it's really a bit) */
1461 size = (int)((SP(vm) - FP(vm)));
1462 for (p = FP(vm), i = 0; i < size; i++, p++) {
1463 vm->stack[i] = *p;
1464 }
1465 /* memmove(vm->stack, FP(vm), (SP(vm) - FP(vm))*sizeof(SgObject)); */
1466 SP(vm) -= FP(vm) - vm->stack;
1467 FP(vm) = vm->stack;
1468
1469 /* for GC friendliness */
1470 for (p = SP(vm); p < vm->stackEnd; p++) *p = NULL;
1471 }
1472
1473 static SgWord return_code[1] = {SG_WORD(RET)};
1474
1475 #define PC_TO_RETURN return_code
1476
1477 static SgObject throw_continuation_cc(SgObject, void **);
1478
throw_continuation_body(SgObject handlers,SgContinuation * c,SgObject args)1479 static SgObject throw_continuation_body(SgObject handlers,
1480 SgContinuation *c,
1481 SgObject args)
1482 {
1483 SgVM *vm = Sg_VM();
1484 /* (if (not (eq? new (current-dynamic-winders))) perform-dynamic-wind) */
1485 if (SG_PAIRP(handlers)) {
1486 SgObject handler, chain;
1487 void *data[3];
1488 handler = SG_CAAR(handlers);
1489 chain = SG_CDAR(handlers);
1490 data[0] = (void*)SG_CDR(handlers);
1491 data[1] = (void*)c;
1492 data[2] = (void*)args;
1493 Sg_VMPushCC(throw_continuation_cc, data, 3);
1494 vm->dynamicWinders = chain;
1495 return Sg_VMApply0(handler);
1496 } else {
1497 /*
1498 if the target continuation is a full continuation, we can abandon
1499 the current continuation. however, if the target continuation is
1500 partial, we must return to the current continuation after executing
1501 the partial continuation.
1502 */
1503 if (c->cstack == NULL) save_cont(vm);
1504
1505 vm->cont = c->cont;
1506 vm->pc = return_code;
1507 vm->dynamicWinders = c->winders;
1508
1509 /* store arguments of the continuation to ac */
1510 if (SG_NULLP(args)) { /* no value */
1511 /* does this happen? */
1512 vm->ac = SG_UNDEF;
1513 vm->valuesCount = 0;
1514 } else if (SG_NULLP(SG_CDR(args))) { /* usual case */
1515 vm->ac = SG_CAR(args);
1516 vm->valuesCount = 1;
1517 } else { /* multi values */
1518 SgObject ap;
1519 int argc = (int)Sg_Length(args), i;
1520 /* when argc == DEFAULT_VALUES_SIZE+1, it must be in pre-allocated
1521 buffer */
1522 if (argc > DEFAULT_VALUES_SIZE+1) {
1523 SG_ALLOC_VALUES_BUFFER(vm, argc - DEFAULT_VALUES_SIZE -1);
1524 }
1525 vm->ac = SG_CAR(args);
1526 for (i = 0, ap = SG_CDR(args); SG_PAIRP(ap); i++, ap = SG_CDR(ap)) {
1527 SG_VALUES_SET(vm, i, SG_CAR(ap));
1528 }
1529 vm->valuesCount = argc;
1530 }
1531
1532 return vm->ac;
1533 }
1534 }
throw_continuation_cc(SgObject result,void ** data)1535 static SgObject throw_continuation_cc(SgObject result, void **data)
1536 {
1537 SgObject handlers = SG_OBJ(data[0]);
1538 SgContinuation *c = (SgContinuation*)data[1];
1539 SgObject args = SG_OBJ(data[2]);
1540 return throw_continuation_body(handlers, c, args);
1541 }
1542
1543 /* remove and re-order continuation's handlers */
remove_common_winders(SgObject current,SgObject escapes)1544 static SgObject remove_common_winders(SgObject current, SgObject escapes)
1545 {
1546 SgObject r = SG_NIL, p;
1547 SG_FOR_EACH(p, escapes) {
1548 if (SG_FALSEP(Sg_Memq(SG_CAR(p), current))) {
1549 r = Sg_Cons(SG_CAR(p), r);
1550 }
1551 }
1552 return r;
1553 }
1554
throw_continuation_calculate_handlers(SgContinuation * c,SgVM * vm)1555 static SgObject throw_continuation_calculate_handlers(SgContinuation *c,
1556 SgVM *vm)
1557 {
1558 SgObject current = vm->dynamicWinders;
1559 SgObject target = remove_common_winders(current, c->winders);
1560 SgObject h = SG_NIL, t = SG_NIL, p;
1561
1562 SG_FOR_EACH(p, current) {
1563 if (!SG_FALSEP(Sg_Memq(SG_CAR(p), c->winders))) break;
1564 SG_APPEND1(h, t, Sg_Cons(SG_CDAR(p), SG_CDR(p)));
1565 }
1566 SG_FOR_EACH(p, target) {
1567 SgObject chain = Sg_Memq(SG_CAR(p), c->winders);
1568 SG_APPEND1(h, t, Sg_Cons(SG_CAAR(p), SG_CDR(chain)));
1569 }
1570 return h;
1571 }
1572
throw_continuation(SgObject * argframes,int argc,void * data)1573 static SgObject throw_continuation(SgObject *argframes, int argc, void *data)
1574 {
1575 SgContinuation *c = (SgContinuation*)data;
1576 SgObject handlers_to_call;
1577 SgVM *vm = Sg_VM();
1578
1579 if (c->cstack && vm->cstack != c->cstack) {
1580 SgCStack *cs;
1581 for (cs = vm->cstack; cs; cs = cs->prev) {
1582 if (c->cstack == cs) break;
1583 }
1584 if (cs != NULL) {
1585 vm->escapeReason = SG_VM_ESCAPE_CONT;
1586 vm->escapeData[0] = c;
1587 vm->escapeData[1] = argframes[0];
1588 longjmp(vm->cstack->jbuf, 1);
1589 }
1590 save_cont(vm);
1591 }
1592
1593 handlers_to_call = throw_continuation_calculate_handlers(c, vm);
1594 return throw_continuation_body(handlers_to_call, c, argframes[0]);
1595 }
1596
Sg_VMCallCC(SgObject proc)1597 SgObject Sg_VMCallCC(SgObject proc)
1598 {
1599 SgContinuation *cont;
1600 SgObject contproc;
1601 SgVM *vm = Sg_VM();
1602
1603 save_cont(vm);
1604 cont = SG_NEW(SgContinuation);
1605 cont->winders = vm->dynamicWinders;
1606 cont->cont = vm->cont;
1607 cont->cstack = vm->cstack;
1608 cont->prev = NULL;
1609 cont->ehandler = SG_FALSE;
1610
1611
1612 contproc = Sg_MakeSubr(throw_continuation, cont, 0, 1,
1613 SG_MAKE_STRING("continuation"));
1614 return Sg_VMApply1(proc, contproc);
1615 }
1616
1617 /*
1618 call with partial contnuation.
1619 */
Sg_VMCallPC(SgObject proc)1620 SgObject Sg_VMCallPC(SgObject proc)
1621 {
1622 SgContinuation *cont;
1623 SgContFrame *c, *cp;
1624 SgObject contproc;
1625 SgVM *vm = Sg_VM();
1626
1627 /*
1628 save the continuation.
1629 */
1630 save_partial_cont(vm);
1631 for (c = vm->cont, cp = NULL;
1632 c && !BOUNDARY_FRAME_MARK_P(c);
1633 cp = c, c = c->prev)
1634 /* do nothing */;
1635
1636 if (cp != NULL) cp->prev = NULL; /* cut the dynamic chain */
1637
1638 cont = SG_NEW(SgContinuation);
1639 cont->winders = vm->dynamicWinders;
1640 cont->cont = (cp? vm->cont : NULL);
1641 cont->prev = NULL;
1642 cont->ehandler = SG_FALSE;
1643 cont->cstack = NULL; /* so that the partial continuation can be
1644 run on any cstack state. */
1645
1646
1647 contproc = Sg_MakeSubr(throw_continuation, cont, 0, 1,
1648 SG_MAKE_STRING("partial continuation"));
1649 /* Remove the saved continuation chain */
1650 vm->cont = c;
1651 return Sg_VMApply1(proc, contproc);
1652 }
1653
1654 /* given load path must be unshifted.
1655 NB: we don't check the validity of given path.
1656 */
replace_file_separator(SgString * path)1657 static SgString* replace_file_separator(SgString *path)
1658 {
1659 SgPort *ret = SG_PORT(Sg_MakeStringOutputPort(SG_STRING_SIZE(path)));
1660 int i;
1661 for (i = 0; i < SG_STRING_SIZE(path); i++) {
1662 /* we need to check both '/' and '\\' */
1663 SgChar c = SG_STRING_VALUE_AT(path, i);
1664 switch (c) {
1665 case '/':
1666 case '\\':
1667 Sg_PutuzUnsafe(ret, Sg_NativeFileSeparator());
1668 break;
1669 default:
1670 Sg_PutcUnsafe(ret, c);
1671 break;
1672 }
1673 }
1674 return SG_STRING(Sg_GetStringFromStringPort(SG_STRING_PORT(ret)));
1675 }
1676
Sg_AddLoadPath(SgString * path,int appendP)1677 SgObject Sg_AddLoadPath(SgString *path, int appendP)
1678 {
1679 SgVM *vm = Sg_VM();
1680 if (SG_STRING_SIZE(path) != 0) {
1681 path = replace_file_separator(path);
1682 if (appendP && !SG_NULLP(vm->loadPath)) {
1683 SgObject last = Sg_LastPair(vm->loadPath);
1684 SG_SET_CDR(last, SG_LIST1(path));
1685 } else {
1686 vm->loadPath = Sg_Cons(path, vm->loadPath);
1687 }
1688 }
1689 return vm->loadPath;
1690 }
1691
Sg_AddDynamicLoadPath(SgString * path,int appendP)1692 SgObject Sg_AddDynamicLoadPath(SgString *path, int appendP)
1693 {
1694 SgVM *vm = Sg_VM();
1695 if (SG_STRING_SIZE(path) != 0) {
1696 path = replace_file_separator(path);
1697 if (appendP && !SG_NULLP(vm->dynamicLoadPath)) {
1698 SgObject last = Sg_LastPair(vm->dynamicLoadPath);
1699 SG_SET_CDR(last, SG_LIST1(path));
1700 } else {
1701 vm->dynamicLoadPath = Sg_Cons(path, vm->dynamicLoadPath);
1702 }
1703 }
1704 return vm->dynamicLoadPath;
1705 }
1706
get_stack_trace(SgContFrame * cont,SgObject cl,SgWord * pc)1707 static SgObject get_stack_trace(SgContFrame *cont, SgObject cl, SgWord *pc)
1708 {
1709 SgObject r = SG_NIL, cur = SG_NIL, prev = SG_UNDEF;
1710 SgVM *vm = Sg_VM();
1711 int i;
1712 for (i = 0;;) {
1713 if (SG_PROCEDUREP(cl)) {
1714 SgObject name = SG_PROCEDURE_NAME(cl);
1715 if (SG_EQ(prev, name)) goto next_cont;
1716 prev = name;
1717 switch (SG_PROCEDURE_TYPE(cl)) {
1718 case SG_PROC_SUBR:
1719 if (SG_FALSEP(name)) goto next_cont;
1720 r = SG_LIST3(SG_INTERN("*cproc*"), name, SG_NIL);
1721 break;
1722 case SG_PROC_CLOSURE:
1723 if (SG_CLOSURE(cl)->code
1724 && SG_CODE_BUILDERP(SG_CLOSURE(cl)->code)) {
1725 SgObject src = get_closure_source(cl, pc);
1726 if (SG_FALSEP(src)) {
1727 src = SG_CODE_BUILDER(SG_CLOSURE(cl)->code)->src;
1728 } else {
1729 /* need to be alist */
1730 src = SG_LIST1(src);
1731 }
1732 r = SG_LIST3(SG_INTERN("*proc*"), name, src);
1733 } else {
1734 r = SG_LIST3(SG_INTERN("*proc*"), name, SG_NIL);
1735 }
1736 break;
1737 default: break; /* never happen? */
1738 }
1739 i++;
1740 } else {
1741 /* should not be here */
1742 ASSERT(FALSE);
1743 }
1744
1745 cur = Sg_Acons(SG_MAKE_INT(i), r, cur);
1746 next_cont:
1747 if (!IN_STACK_P((SgObject *)cont, vm) ||
1748 (uintptr_t)cont > (uintptr_t)vm->stack) {
1749
1750 SgContFrame *nextCont;
1751 cl = cont->cl;
1752 pc = cont->pc;
1753 if (!cl) break;
1754 if (!SG_PROCEDUREP(cl)) {
1755 break;
1756 }
1757 nextCont = cont->prev;
1758 if (!SG_PTRP(nextCont)) {
1759 break;
1760 }
1761 if (IN_STACK_P((SgObject *)nextCont, vm) &&
1762 ((uintptr_t)nextCont < (uintptr_t)vm->stack ||
1763 (uintptr_t)vm->stackEnd < (uintptr_t)nextCont)) {
1764 break;
1765 }
1766 cont = nextCont;
1767 } else {
1768 break;
1769 }
1770 }
1771 return cur;
1772 }
1773
1774 /* returns alist of stack trace. */
Sg_GetStackTrace()1775 SgObject Sg_GetStackTrace()
1776 {
1777 SgVM *vm = Sg_VM();
1778 SgContFrame *cont = CONT(vm);
1779 SgObject cl = CL(vm);
1780 SgWord *pc = PC(vm);
1781
1782 if (!cl) {
1783 /* before running */
1784 return SG_NIL;
1785 }
1786 /* if (vm->state == COMPILING || vm->state == IMPORTING) return SG_NIL; */
1787 /* get current posision's src */
1788 return get_stack_trace(cont, cl, pc);
1789 }
1790
Sg_GetStackTraceFromCont(SgContFrame * cont)1791 SgObject Sg_GetStackTraceFromCont(SgContFrame *cont)
1792 {
1793 return get_stack_trace(cont, cont->cl, cont->pc);
1794 }
1795
1796 /*
1797 ;; image of the definitions
1798
1799 */
1800 static SgObject raise_proc = SG_FALSE;
1801 static SgObject raise_continuable_proc = SG_FALSE;
1802
raise_cc(SgObject result,void ** data)1803 static SgObject raise_cc(SgObject result, void **data)
1804 {
1805 SgObject e = SG_OBJ(data[0]);
1806 SgObject p = SG_OBJ(data[1]);
1807 return Sg_VMApply1(p, e);
1808 }
1809
1810 /*
1811 This change makes raise or raise-continuable and saving raised condition
1812 a bit more expensive than before (and may cause memory explosion). The
1813 basic idea of this change is that using continuation frame as a stack
1814 trace so that nested stack trace can be detected easily. To make this
1815 happen, we save all frames into the heap as if call/cc is called when
1816 raise/raise-contiuable is called.
1817
1818 Above sounds kinda horrible however if we implement segmented stacks type
1819 call/cc described the blow paper, then this performance penalty wouldn't be
1820 a problem.
1821 - Representing Control in the Presence of First-Class Continuations
1822 URL: http://www.cs.indiana.edu/~dyb/papers/stack.ps
1823 Not sure if this happens in near future but we may review the current
1824 implementation of call/cc if the performance would be an issue.
1825 */
Sg_VMAttachStackTrace(SgVM * vm,SgObject condition,int skipTop)1826 SgObject Sg_VMAttachStackTrace(SgVM *vm, SgObject condition, int skipTop)
1827 {
1828 if (Sg_CompoundConditionP(condition)) {
1829 SgContFrame *save;
1830 SgObject cl;
1831 SgWord *pc;
1832 save_cont(vm);
1833 save = vm->cont;
1834 cl = vm->cl;
1835 pc = vm->pc;
1836 if (skipTop) {
1837 vm->cont = vm->cont->prev;
1838 vm->cl = vm->cont->cl;
1839 vm->pc = vm->cont->pc;
1840 }
1841 condition = Sg_AddStackTrace(condition, vm);
1842 vm->cont = save;
1843 vm->cl = cl;
1844 vm->pc = pc;
1845 }
1846 return condition;
1847 }
1848
Sg_VMThrowException(SgVM * vm,SgObject exception,int continuableP)1849 SgObject Sg_VMThrowException(SgVM *vm, SgObject exception, int continuableP)
1850 {
1851 exception = Sg_VMAttachStackTrace(vm, exception, FALSE);
1852 /* should never happen but I usually make mistake so lean to safer side. */
1853 if (SG_NULLP(vm->exceptionHandlers)) {
1854 vm->exceptionHandlers = DEFAULT_EXCEPTION_HANDLER;
1855 }
1856
1857 if (vm->exceptionHandlers != DEFAULT_EXCEPTION_HANDLER) {
1858 /*
1859 To avoid calling exception handers outside of current continuation
1860 (c.f. using Sg_Apply families), we need call raise/raise-continuable
1861 defined in Scheme (see boot/lib/errors.scm). To do it, we set flag
1862 here and escape from current C stack. If the run_loop procedure
1863 sees the flag, then it handles this call properly.
1864 */
1865 void *data[2];
1866 data[0] = exception;
1867 if (continuableP) {
1868 data[1] = raise_continuable_proc;
1869 } else {
1870 data[1] = raise_proc;
1871 }
1872 vm->escapeReason = SG_VM_ESCAPE_RAISE;
1873 Sg_VMPushCC(raise_cc, data, 2);
1874 longjmp(vm->cstack->jbuf, 1);
1875 }
1876 /* short cut, if there's no exception handlers, then we don't have to
1877 call it. we know what should happen.
1878 */
1879 Sg_VMDefaultExceptionHandler(exception);
1880 return SG_UNDEF; /* dummy */
1881 }
1882
1883 #ifndef EX_SOFTWARE
1884 /* SRFI-22 requires this. */
1885 #define EX_SOFTWARE 70
1886 #endif
1887
1888 /* default exception handler */
Sg_VMDefaultExceptionHandler(SgObject e)1889 void Sg_VMDefaultExceptionHandler(SgObject e)
1890 {
1891 SgVM *vm = Sg_VM();
1892 SgContinuation *c = vm->escapePoint;
1893 SgObject hp;
1894
1895 if (c) {
1896 SgObject result = SG_FALSE, dvals[DEFAULT_VALUES_SIZE], *rvals;
1897 SgObject target, current;
1898 int valscount = 0, i, ext_count = 0;
1899 /* never reaches for now. */
1900 if (c->rewindBefore) {
1901 target = c->winders;
1902 current = vm->dynamicWinders;
1903 for (hp = current; SG_PAIRP(hp) && (hp != target); hp = SG_CDR(hp)) {
1904 SgObject proc = SG_CDAR(hp);
1905 vm->dynamicWinders = SG_CDR(hp);
1906 Sg_Apply0(proc);
1907 }
1908 }
1909 vm->escapePoint = c->prev;
1910 SG_VM_FLOATING_EP_SET(vm, c);
1911
1912 rvals = dvals;
1913 SG_UNWIND_PROTECT {
1914 result = Sg_Apply1(c->ehandler, e);
1915 if ((valscount = vm->valuesCount) > 1) {
1916 if (valscount > DEFAULT_VALUES_SIZE+1) {
1917 rvals = SG_NEW_ARRAY(SgObject, valscount -1);
1918 }
1919 for (i = 0; i < valscount - 1; i++) {
1920 rvals[i] = SG_VALUES_REF(vm, i);
1921 }
1922 }
1923 if (!c->rewindBefore) {
1924 target = c->winders;
1925 current = vm->dynamicWinders;
1926 for (hp = current; SG_PAIRP(hp) && (hp != target); hp = SG_CDR(hp)) {
1927 SgObject proc = SG_CDAR(hp);
1928 vm->dynamicWinders = SG_CDR(hp);
1929 Sg_Apply0(proc);
1930 }
1931 }
1932 }
1933 SG_WHEN_ERROR {
1934 SG_VM_FLOATING_EP_SET(vm, c->floating);
1935 SG_NEXT_HANDLER;
1936 }
1937 SG_END_PROTECT;
1938
1939 /* install the continuation */
1940 if (valscount > DEFAULT_VALUES_SIZE+1) {
1941 SG_ALLOC_VALUES_BUFFER(vm, ext_count);
1942 }
1943 for (i = 0; i < valscount-1; i++) SG_VALUES_SET(vm, i, rvals[i]);
1944
1945 vm->ac = result;
1946 vm->cont = c->cont;
1947 SG_VM_FLOATING_EP_SET(vm, c->floating);
1948 if (c->errorReporting) {
1949 SG_VM_RUNTIME_FLAG_SET(vm, SG_ERROR_BEING_REPORTED);
1950 }
1951 } else {
1952 Sg_ReportErrorInternal(e, vm->currentErrorPort);
1953 SG_FOR_EACH(hp, vm->dynamicWinders) {
1954 SgObject proc = SG_CDAR(hp);
1955 vm->dynamicWinders = SG_CDR(hp);
1956 Sg_Apply0(proc);
1957 }
1958 }
1959 /* jump */
1960 if (vm->cstack) {
1961 vm->escapeReason = SG_VM_ESCAPE_ERROR;
1962 vm->escapeData[0] = c;
1963 vm->escapeData[1] = e;
1964 longjmp(vm->cstack->jbuf, 1);
1965 } else {
1966 /* exit(EX_SOFTWARE); */
1967 Sg_Exit(EX_SOFTWARE);
1968 }
1969 }
1970
default_exception_handler_body(SgObject * args,int argc,void * data)1971 static SgObject default_exception_handler_body(SgObject *args,
1972 int argc, void *data)
1973 {
1974 ASSERT(argc == 1);
1975 Sg_VMDefaultExceptionHandler(args[0]);
1976 return SG_UNDEF;
1977 }
1978
1979 static SG_DEFINE_SUBR(default_exception_handler_rec, 1, 0,
1980 default_exception_handler_body,
1981 SG_FALSE, NULL);
1982
1983 #define TAIL_POS(vm) (*PC(vm) == RET)
1984
1985 #define POP_CONT() \
1986 do { \
1987 if (CONT(vm)->fp == C_CONT_MARK) { \
1988 void *data__[SG_CCONT_DATA_SIZE]; \
1989 SgObject v__ = AC(vm); \
1990 SgCContinuationProc *after__; \
1991 void **d__ = data__; \
1992 void **s__ = (void**)((SgObject*)CONT(vm) + CONT_FRAME_SIZE); \
1993 int i__ = CONT(vm)->size; \
1994 while (i__-- > 0) { \
1995 *d__++ = *s__++; \
1996 } \
1997 after__ = ((SgCContinuationProc*)CONT(vm)->pc); \
1998 if (IN_STACK_P((SgObject*)CONT(vm), vm)) { \
1999 SP(vm) = (SgObject*)CONT(vm); \
2000 } \
2001 FP(vm) = SP(vm); \
2002 PC(vm) = PC_TO_RETURN; \
2003 CL(vm) = CONT(vm)->cl; \
2004 CONT(vm) = CONT(vm)->prev; \
2005 AC(vm) = after__(v__, data__); \
2006 } else if (IN_STACK_P((SgObject*)CONT(vm), vm)) { \
2007 SgContFrame *cont__ = CONT(vm); \
2008 CONT(vm) = cont__->prev; \
2009 PC(vm) = cont__->pc; \
2010 CL(vm) = cont__->cl; \
2011 FP(vm) = cont__->fp; \
2012 SP(vm) = FP(vm) + cont__->size; \
2013 } else { \
2014 int size__ = CONT(vm)->size; \
2015 FP(vm) = SP(vm) = vm->stack; \
2016 PC(vm) = CONT(vm)->pc; \
2017 CL(vm) = CONT(vm)->cl; \
2018 if (size__) { \
2019 SgObject *s__ = CONT(vm)->env, *d__ = SP(vm); \
2020 SP(vm) += size__; \
2021 while (size__-- > 0) { \
2022 *d__++ = *s__++; \
2023 } \
2024 } \
2025 CONT(vm) = CONT(vm)->prev; \
2026 } \
2027 } while (0)
2028
2029 /*
2030 Finalizers also occupy memory space and if we don't invoke
2031 them, then it only grows. This case only happens only on
2032 multi thread environment and the execution raised an error
2033 or numbers of GC happened after returning from run_loop (
2034 not even sure this would happen though).
2035
2036 Seems this would cause more problem than profit.
2037 */
2038 #define RUN_FINALIZER(vm) \
2039 do { \
2040 if ((vm)->finalizerPending) Sg_VMFinalizerRun(vm); \
2041 } while (0)
2042
evaluate_safe(SgObject program,SgWord * code)2043 SgObject evaluate_safe(SgObject program, SgWord *code)
2044 {
2045 SgCStack cstack;
2046 SgVM * volatile vm = Sg_VM();
2047 SgWord * volatile prev_pc = PC(vm);
2048
2049 CHECK_STACK(CONT_FRAME_SIZE, vm);
2050 PUSH_CONT(vm, &boundaryFrameMark);
2051 FP(vm) = (SgObject*)CONT(vm) + CONT_FRAME_SIZE;
2052
2053 ASSERT(SG_PROCEDUREP(program));
2054 CL(vm) = program;
2055
2056 if (code != NULL) {
2057 PC(vm) = code;
2058 } else {
2059 ASSERT(SG_CLOSUREP(CL(vm)));
2060 PC(vm) = SG_CODE_BUILDER(SG_CLOSURE(CL(vm))->code)->code;
2061 }
2062 cstack.prev = vm->cstack;
2063 cstack.cont = vm->cont;
2064 vm->cstack = &cstack;
2065
2066 restart:
2067 vm->escapeReason = SG_VM_ESCAPE_NONE;
2068 if (setjmp(cstack.jbuf) == 0) {
2069 run_loop();
2070 /* RUN_FINALIZER(vm); */
2071 if (vm->cont == cstack.cont) {
2072 POP_CONT();
2073 PC(vm) = prev_pc;
2074 } else if (vm->cont == NULL) {
2075 /* we're finished with executing partial continuation */
2076 vm->cont = cstack.cont;
2077 POP_CONT();
2078 PC(vm) = prev_pc;
2079 } else {
2080 /* The VM's SP and FP registers are initialised as the same
2081 pointer, this causes call/cc save duplicated boundary mark
2082 and make it cyclic.
2083 e.g.) This would an error
2084 (import (rnrs) (srfi :18))
2085
2086 (define (thunk) (guard (e (else (raise e))) (print 'ok)))
2087 (thread-join! (thread-start! (make-thread thunk)))
2088
2089 Above case the last and the second last frame's prev indicates
2090 the last frame as it should be, however the last frame's
2091 prev indicates the second last frame.
2092 To detect such situation, we need to allow cyclic boundaries.
2093 NOTE: a lot of things are depending on the behaviour so we
2094 can't change it...*/
2095 /* TODO this check might be too naive */
2096 if (vm->cont->prev && vm->cont->prev->prev &&
2097 vm->cont == vm->cont->prev->prev && vm->cont->prev == cstack.cont) {
2098 POP_CONT();
2099 PC(vm) = prev_pc;
2100 } else {
2101 Sg_Error(UC("attempt to return from C continuation boundary."));
2102 }
2103 }
2104
2105 } else {
2106 /* error, let finalizer run first here */
2107 /* RUN_FINALIZER(vm); */
2108 if (vm->escapeReason == SG_VM_ESCAPE_CONT) {
2109 SgContinuation *c = (SgContinuation*)vm->escapeData[0];
2110 if (c->cstack == vm->cstack) {
2111 SgObject handlers = throw_continuation_calculate_handlers(c, vm);
2112 PC(vm) = PC_TO_RETURN;
2113 AC(vm) = throw_continuation_body(handlers, c, vm->escapeData[1]);
2114 goto restart;
2115 } else {
2116 ASSERT(vm->cstack && vm->cstack->prev);
2117 CONT(vm) = cstack.cont;
2118 AC(vm) = vm->ac;
2119 POP_CONT();
2120 vm->cstack = vm->cstack->prev;
2121 longjmp(vm->cstack->jbuf, 1);
2122 }
2123 } else if (vm->escapeReason == SG_VM_ESCAPE_ERROR) {
2124 SgContinuation *c = (SgContinuation*)vm->escapeData[0];
2125 if (c && c->cstack == vm->cstack) {
2126 CONT(vm) = c->cont;
2127 PC(vm) = PC_TO_RETURN;
2128 goto restart;
2129 } else if (vm->cstack->prev == NULL) {
2130 /* exit(EX_SOFTWARE); */
2131 Sg_Exit(EX_SOFTWARE);
2132 } else {
2133 CONT(vm) = cstack.cont;
2134 POP_CONT();
2135 vm->cstack = vm->cstack->prev;
2136 longjmp(vm->cstack->jbuf, 1);
2137 }
2138 } else if (vm->escapeReason == SG_VM_ESCAPE_RAISE) {
2139 PC(vm) = PC_TO_RETURN;
2140 goto restart;
2141 } else {
2142 Sg_Panic("invalid longjmp");
2143 }
2144 }
2145 vm->cstack = vm->cstack->prev;
2146 CLEAR_STACK(vm);
2147 return AC(vm);
2148 }
2149
2150
2151 /*
2152 This method is for compiled library.
2153 compiled library can only have one library on its file.
2154 (it may be changed future but for now)
2155 Library will be compiled only one compiled code, because
2156 one R6RS library is one S-expression.
2157 So, just make a closure and apply it with '()
2158 */
Sg_VMExecute(SgObject toplevel)2159 SgObject Sg_VMExecute(SgObject toplevel)
2160 {
2161 ASSERT(SG_CODE_BUILDERP(toplevel));
2162 /* NB: compiled libraries don't need any frame. */
2163 return evaluate_safe(SG_OBJ(&internal_toplevel_closure),
2164 SG_CODE_BUILDER(toplevel)->code);
2165 }
2166
2167 /*
2168 Shifts argument frame
2169
2170 from
2171 fp m sp
2172 +---+---+---+---+---+
2173 | r | g | g | a | a |
2174 +---+---+---+---+---+
2175 r = remain, g = garbage, a = argument
2176
2177 to
2178 fp sp/m
2179 +---+---+---+
2180 | r | a | a |
2181 +---+---+---+
2182
2183 return SP = fp+m
2184 */
shift_args(SgObject * fp,int m,SgObject * sp)2185 static inline SgObject* shift_args(SgObject *fp, int m, SgObject *sp)
2186 {
2187 /* TODO Use SIMD? */
2188 #if 1
2189 int i;
2190 SgObject *f = fp + m;
2191 for (i = m - 1; 0 <= i; i--) {
2192 INDEX_SET(f, i, INDEX(sp, i));
2193 }
2194 return f;
2195 #else
2196 /* seems this is slower */
2197 memmove(fp, sp-m, m*sizeof(SgObject));
2198 return fp+m;
2199 #endif
2200 }
2201
2202 /* for call-next-method. is there not a better way?
2203
2204 Shifts stack frame.
2205
2206 from
2207 sp
2208 +---+---+
2209 | a | a |
2210 +---+---+
2211 a = argument
2212
2213 to
2214 sp
2215 +---+---+---+
2216 | r | a | a |
2217 +---+---+---+
2218 r = will next method
2219
2220 return SP
2221 */
shift_one_args(SgObject * sp,int m)2222 static inline SgObject* shift_one_args(SgObject *sp, int m)
2223 {
2224 int i;
2225 SgObject *tsp = sp+1;
2226 for (i=0; i<m; i++) {
2227 INDEX_SET(tsp, i, INDEX(sp, i));
2228 }
2229 return tsp;
2230 }
2231
process_queued_requests_cc(SgObject result,void ** data)2232 static SgObject process_queued_requests_cc(SgObject result, void **data)
2233 {
2234 int i;
2235 SgObject cp;
2236 SgVM *vm = Sg_VM();
2237 vm->ac = data[0];
2238 vm->valuesCount = (int)(intptr_t)data[1];
2239 if (vm->valuesCount > 1) {
2240 for (i=0,cp=SG_OBJ(data[2]); i<vm->valuesCount-1; i++, cp=SG_CDR(cp)) {
2241 SG_VALUES_SET(vm, i, SG_CAR(cp));
2242 }
2243 }
2244 if (vm->valuesCount < DEFAULT_VALUES_SIZE) {
2245 vm->extra_values = NULL;
2246 }
2247 SG_RESET_INTERRUPTED_THREAD(vm);
2248 return vm->ac;
2249 }
2250
process_queued_requests(SgVM * vm)2251 static void process_queued_requests(SgVM *vm)
2252 {
2253 void *data[3];
2254 /* preserve the current continuation */
2255 data[0] = (void*)vm->ac;
2256 data[1] = (void*)(intptr_t)vm->valuesCount;
2257 if (vm->valuesCount > 1) {
2258 int i;
2259 SgObject h = SG_NIL, t = SG_NIL;
2260 for (i = 0; i < vm->valuesCount-1; i++) {
2261 SG_APPEND1(h, t, SG_VALUES_REF(vm, i));
2262 }
2263 data[2] = h;
2264 } else {
2265 data[2] = SG_NIL;
2266 }
2267
2268 Sg_VMPushCC(process_queued_requests_cc, data, 3);
2269
2270 vm->attentionRequest = FALSE;
2271
2272 if (vm->finalizerPending) Sg_VMFinalizerRun(vm);
2273
2274 if (vm->stopRequest) {
2275 SG_INTERNAL_MUTEX_SAFE_LOCK_BEGIN(vm->vmlock);
2276 switch (vm->stopRequest) {
2277 case SG_VM_REQUEST_SUSPEND:
2278 vm->stopRequest = FALSE;
2279 vm->threadState = SG_VM_STOPPED;
2280 Sg_NotifyAll(&vm->cond);
2281 while (vm->threadState == SG_VM_STOPPED) {
2282 Sg_Wait(&vm->cond, &vm->vmlock);
2283 }
2284 break;
2285 case SG_VM_REQUEST_TERMINATE:
2286 vm->threadState = SG_VM_TERMINATED;
2287 break;
2288 }
2289 SG_INTERNAL_MUTEX_SAFE_LOCK_END();
2290 if (vm->threadState == SG_VM_TERMINATED) {
2291 Sg_ExitThread(&vm->thread, NULL);
2292 }
2293 }
2294 }
2295
2296 #define RET_INSN() \
2297 do { \
2298 if (CONT(vm) == NULL || BOUNDARY_FRAME_MARK_P(CONT(vm))) { \
2299 /* no more continuation */ \
2300 return AC(vm); \
2301 } \
2302 POP_CONT(); \
2303 } while (0) \
2304
2305 /*
2306 print call frames
2307
2308 call frame and let frame model
2309 before calling
2310 +----------------+ <-- sp
2311 | arguments |
2312 +----------------+
2313 | size |
2314 | prev ----|----------+
2315 | : | |
2316 | fp | |
2317 +----------------+ <-- cont |
2318 | argument n | |
2319 | : | |
2320 | argument 0 | |
2321 +----------------+ <-- fp | prev
2322 | size | |
2323 | pc | |
2324 | cl | |
2325 | dc | |
2326 | fp | |
2327 +----------------+ <--------+
2328
2329 after calling
2330 +----------------+ <-- sp
2331 | arguments |
2332 +----------------+ <-- fp
2333 | size |
2334 | prev ----|----------+
2335 | : | |
2336 | fp | |
2337 +----------------+ <-- cont |
2338 | argument n | |
2339 | : | |
2340 | argument 0 | |
2341 +----------------+ | prev
2342 | size | |
2343 | pc | |
2344 | cl | |
2345 | dc | |
2346 | fp | |
2347 +----------------+ <--------+
2348
2349 we can follow the stack with cont register.
2350 to avoid segmentation fault, we need to be careful with let frame.
2351 so make sure if it's fp or not before touch an stack element.
2352 */
print_cont1(SgContFrame * cont,SgVM * vm)2353 static SgContFrame * print_cont1(SgContFrame *cont, SgVM *vm)
2354 {
2355 SgObject *current = (SgObject *)cont;
2356 int i;
2357 int size = cont->size;
2358 int c_func = FALSE;
2359 SgString *clfmt = SG_MAKE_STRING("+ cl=~38,,,,39s +~%");
2360 Sg_Printf(vm->logPort,
2361 UC(";; 0x%x +---------------------------------------------+\n"),
2362 current);
2363 Sg_Printf(vm->logPort, UC(";; 0x%x + size=%#38d +\n"),
2364 (uintptr_t)cont + offsetof(SgContFrame, size), cont->size);
2365 Sg_Printf(vm->logPort, UC(";; 0x%x + pc=%#38x +\n"),
2366 (uintptr_t)cont + offsetof(SgContFrame, pc), cont->pc);
2367 Sg_Printf(vm->logPort, UC(";; 0x%x "),
2368 (uintptr_t)cont + offsetof(SgContFrame, cl));
2369 if (cont->cl) {
2370 Sg_Format(vm->logPort, clfmt, SG_LIST1(cont->cl), TRUE);
2371 } else {
2372 Sg_Format(vm->logPort, clfmt, SG_LIST1(SG_FALSE), TRUE);
2373 }
2374 Sg_Printf(vm->logPort, UC(";; 0x%x + fp=%#38x +\n"),
2375 (uintptr_t)cont + offsetof(SgContFrame, fp), cont->fp);
2376 Sg_Printf(vm->logPort, UC(";; 0x%x + prev=%#38x +\n"),
2377 (uintptr_t)cont + offsetof(SgContFrame, prev), cont->prev);
2378 if (cont == CONT(vm)) {
2379 Sg_Printf(vm->logPort,
2380 UC(";; 0x%x +---------------------------------------------+ < cont%s\n"),
2381 cont, BOUNDARY_FRAME_MARK_P(cont) ? UC(" (boundary)") : UC(""));
2382 } else if (cont->prev) {
2383 Sg_Printf(vm->logPort,
2384 UC(";; 0x%x +---------------------------------------------+ < prev%s\n"),
2385 cont, BOUNDARY_FRAME_MARK_P(cont) ? UC(" (boundary)") : UC(""));
2386 }
2387 if (cont->fp == C_CONT_MARK) c_func = TRUE;
2388 else c_func = FALSE;
2389
2390 size = cont->size;
2391 /* cont's size is argc of previous cont frame */
2392 /* dump arguments */
2393 if (IN_STACK_P((SgObject*)cont, vm)) {
2394 if (!c_func) {
2395 for (i = 0; i < size; i++, current--) {
2396 Sg_Printf(vm->logPort, UC(";; 0x%x + p=%#39x +\n"), current,
2397 *(current));
2398 }
2399 }
2400 } else {
2401 if (!c_func) {
2402 for (i = 0; i < size; i++) {
2403 Sg_Printf(vm->logPort, UC(";; 0x%x + p=%#39x +\n"), cont->env+i,
2404 *(cont->env+i));
2405 }
2406 }
2407 }
2408 if (!cont->cl) return NULL;
2409 return cont->prev;
2410 }
2411
print_frames(SgVM * vm,SgContFrame * cont)2412 static void print_frames(SgVM *vm, SgContFrame *cont)
2413 {
2414 SgObject *stack = vm->stack, *sp = SP(vm);
2415 SgObject *current = sp - 1;
2416
2417 Sg_Printf(vm->logPort, UC(";; stack: 0x%x, cont: 0x%x\n"), stack, cont);
2418
2419 /* first dump cont in heap */
2420 while (!IN_STACK_P((SgObject *)cont, vm)) {
2421 cont = print_cont1(cont, vm);
2422 if (!cont) break;
2423 }
2424 if (!cont) goto end;
2425
2426 Sg_Printf(vm->logPort, UC(";; 0x%x +---------------------------------------------+ < sp\n"), sp);
2427 /* second we dump from top until cont frame. */
2428 while ((stack < current && current <= sp)) {
2429 if (current == (SgObject*)cont + CONT_FRAME_SIZE) {
2430 break;
2431 }
2432 Sg_Printf(vm->logPort, UC(";; 0x%x + p=%#39x +\n"), current, *current);
2433 current--;
2434 }
2435 /* now we know we just need to trace cont frames
2436 memo: if cont has let frame, we just dump it as pointer.
2437 */
2438 while (stack < current && current <= sp) {
2439 /* the very first arguments are ignored */
2440 while (current > (SgObject *)cont + CONT_FRAME_SIZE) {
2441 Sg_Printf(vm->logPort, UC(";; 0x%x + p=%#39x +\n"), current, *current);
2442 current--;
2443 }
2444 Sg_Printf(vm->logPort, UC(";; 0x%x + p=%#39x +\n"), current, *current);
2445
2446 current = (SgObject *)cont;
2447 cont = print_cont1(cont, vm);
2448 if (!cont) break;
2449 }
2450 end:
2451 Sg_Printf(vm->logPort, UC(";; 0x%x +---------------------------------------------+\n"), stack);
2452 }
2453
Sg_VMPrintFrameFrom(SgContFrame * cont)2454 void Sg_VMPrintFrameFrom(SgContFrame *cont)
2455 {
2456 print_frames(Sg_VM(), cont);
2457 }
2458
Sg_VMPrintFrame()2459 void Sg_VMPrintFrame()
2460 {
2461 print_frames(Sg_VM(), CONT(Sg_VM()));
2462 }
2463
Sg_VMPrintFrameOf(SgVM * vm)2464 void Sg_VMPrintFrameOf(SgVM *vm)
2465 {
2466 print_frames(vm, CONT(vm));
2467 }
2468
2469 #ifdef PROF_INSN
2470 #define COUNT_INSN(c) if (vm->state == RUNNING) called_instructions[INSN(c)]++
2471 static int called_instructions[INSTRUCTION_COUNT] = {0};
show_inst_count(void * data)2472 static void show_inst_count(void *data)
2473 {
2474 int i;
2475 for (i = 0; i < INSTRUCTION_COUNT; i++) {
2476 if (called_instructions[i]) {
2477 InsnInfo *info = Sg_LookupInsnName(i);
2478 fprintf(stderr, "INSN: %s(%d)\n", info->name, called_instructions[i]);
2479 }
2480 }
2481 }
2482 #else
2483 #define COUNT_INSN(c) /* dummy */
2484 #endif
2485
2486 #define FETCH_OPERAND(pc) SG_OBJ((*(pc)++))
2487 #define PEEK_OPERAND(pc) ((intptr_t)(*(pc)))
2488
2489 #ifdef __GNUC__
2490 # define SWITCH(val) goto *dispatch_table[val];
2491 # define CASE(insn) /* dummy */
2492 # define DISPATCH /* empty */
2493 # define NEXT \
2494 do { \
2495 c = (SgWord)FETCH_OPERAND(PC(vm)); \
2496 COUNT_INSN(c); \
2497 goto *dispatch_table[INSN(c)]; \
2498 } while (0)
2499 # define DEFAULT /* dummy */
2500 #else
2501 # define SWITCH(val) switch (val)
2502 # define CASE(insn) case insn :
2503 # define NEXT goto dispatch;
2504 # define DISPATCH dispatch:
2505 # define DEFAULT default:
2506 #endif
2507
2508 /*
2509 VM interruption happens only certain situation like the followings:
2510 - GC
2511 - Thread interrpution (only POSIX)
2512 - Thread stop/termination
2513 Thread related thing does not really matter since it just proceed the
2514 process. So what we need to care is GC. Thus just referring variable
2515 doesn't have to check such as LREF.
2516 */
2517 #define CHECK_ATTENTION \
2518 do { if (vm->attentionRequest) goto process_queue; } while (0)
2519
2520 #ifdef _MSC_VER
2521 # pragma warning( push )
2522 # pragma warning( disable : 4102 4101)
2523 #endif
2524
run_loop()2525 SgObject run_loop()
2526 {
2527 SgVM *vm = Sg_VM();
2528
2529 #ifdef __GNUC__
2530 static void *dispatch_table[INSTRUCTION_COUNT] = {
2531 #define DEFINSN(insn, vals, argc, src, label) && SG_CPP_CAT(label_, insn),
2532 #include "vminsn.c"
2533 #undef DEFINSN
2534 };
2535 #endif /* __GNUC__ */
2536
2537 for (;;) {
2538 SgWord c;
2539
2540 DISPATCH;
2541 /* if (vm->attentionRequest) goto process_queue; */
2542 c = (SgWord)FETCH_OPERAND(PC(vm));
2543 COUNT_INSN(c);
2544 SWITCH(INSN(c)) {
2545 #define VM_LOOP
2546 #include "vminsn.c"
2547 #undef VM_LOOP
2548 DEFAULT {
2549 #ifdef _MSC_VER
2550 __assume(0);
2551 #else
2552 Sg_Panic("unknown instruction appeard. %08x", c);
2553 #endif
2554 }
2555 }
2556 process_queue:
2557 CHECK_STACK(CONT_FRAME_SIZE, vm);
2558 PUSH_CONT(vm, PC(vm));
2559 process_queued_requests(vm);
2560 POP_CONT();
2561 NEXT;
2562
2563 }
2564 return SG_UNDEF; /* dummy */
2565
2566 #undef REFER_GLOBAL
2567 #undef FIND_GLOBAL
2568 }
2569 #ifdef _MSC_VER
2570 # pragma warning( pop )
2571 #endif
2572
Sg__InitVM()2573 void Sg__InitVM()
2574 {
2575 /* this env is p1env and it must be 5 elements vector for now. */
2576 #if defined(_MSC_VER) || defined(_SG_WIN_SUPPORT)
2577 rootVM = theVM = Sg_NewVM(NULL, SG_MAKE_STRING("root"));
2578 #else
2579 if (pthread_key_create(&the_vm_key, NULL) != 0) {
2580 Sg_Panic("pthread_key_create failed.");
2581 }
2582 rootVM = Sg_NewVM(NULL, SG_MAKE_STRING("root"));
2583 Sg_SetCurrentVM(rootVM);
2584 #endif
2585 Sg_SetCurrentThread(&rootVM->thread);
2586 rootVM->threadState = SG_VM_RUNNABLE;
2587 rootVM->currentLibrary = Sg_FindLibrary(SG_INTERN("user"), FALSE);
2588 /* mark as this is toplevel library. */
2589 SG_LIBRARY_DEFINEED(rootVM->currentLibrary) = SG_FALSE;
2590
2591 /* load path */
2592 rootVM->loadPath = Sg_GetDefaultLoadPath();
2593 rootVM->dynamicLoadPath = Sg_GetDefaultDynamicLoadPath();
2594
2595 SG_PROCEDURE_NAME(&default_exception_handler_rec) =
2596 SG_MAKE_STRING("default-exception-handler");
2597 Sg_InitMutex(&global_lock, TRUE);
2598
2599 #ifdef PROF_INSN
2600 Sg_AddCleanupHandler(show_inst_count, NULL);
2601 #endif
2602 }
2603
Sg__PostInitVM()2604 void Sg__PostInitVM()
2605 {
2606 SgObject coreErrors = Sg_FindLibrary(SG_INTERN("(core errors)"), FALSE);
2607 SgObject b = Sg_FindBinding(coreErrors, SG_INTERN("raise"), SG_UNBOUND);
2608 if (SG_UNBOUNDP(b)) {
2609 Sg_Panic("`raise` was not found.");
2610 }
2611 raise_proc = SG_GLOC_GET(SG_GLOC(b));
2612 b = Sg_FindBinding(coreErrors, SG_INTERN("raise-continuable"), SG_UNBOUND);
2613 if (SG_UNBOUNDP(b)) {
2614 Sg_Panic("`raise-continuable` was not found.");
2615 }
2616 raise_continuable_proc = SG_GLOC_GET(SG_GLOC(b));
2617 }
2618
2619 /*
2620 end of file
2621 Local Variables:
2622 coding: utf-8-unix
2623 End:
2624 */
2625