diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 14f9f95ab..374f7eec4 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -217,20 +217,22 @@ ;; (br L2) ;; L1: (const #f) ;; L2: - (let ((L1 (make-label)) (L2 (make-label))) - (if (null? exps) - (return-object! loc #t) - (do ((exps exps (cdr exps))) - ((null? (cdr exps)) - (comp-tail (car exps)) - (if (not tail) (push-branch! #f 'br L2)) - (push-label! L1) - (return-object! #f #f) - (if (not tail) (push-label! L2)) - (maybe-drop) - (maybe-return)) - (comp-push (car exps)) - (push-branch! #f 'br-if-not L1))))) + (cond ((null? exps) (return-object! loc #t)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label)) (L2 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-branch! #f 'br L2) + (push-label! L1) + (return-object! #f #f) + (push-label! L2) + (maybe-return)) + (else + (comp-push (car exps)) + (push-branch! #f 'br-if-not L1) + (lp (cdr exps))))))))) (( env loc exps) ;; EXP @@ -240,19 +242,21 @@ ;; ... ;; TAIL ;; L1: - (let ((L1 (make-label))) - (if (null? exps) - (return-object! loc #f) - (do ((exps exps (cdr exps))) - ((null? (cdr exps)) - (comp-tail (car exps)) - (push-label! L1) - (maybe-drop) - (maybe-return)) - (comp-push (car exps)) - (push-call! #f 'dup '()) - (push-branch! #f 'br-if L1) - (push-call! #f 'drop '()))))) + (cond ((null? exps) (return-object! loc #f)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-label! L1) + (maybe-return)) + (else + (comp-push (car exps)) + (push-call! #f 'dup '()) + (push-branch! #f 'br-if L1) + (push-call! #f 'drop '()) + (lp (cdr exps))))))))) (( env loc exps) ;; EXPS... diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 75a500a72..01f6ed430 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -29,7 +29,7 @@ :use-module (system vm vm) :use-module (system vm debug) :use-module (ice-9 rdelim) - :export (start-repl)) + :export (start-repl call-with-backtrace)) (define meta-command-token (cons 'meta 'command)) diff --git a/src/vm.c b/src/vm.c index c3fbc944f..127fe70b1 100644 --- a/src/vm.c +++ b/src/vm.c @@ -560,8 +560,18 @@ SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0, SCM *dest; SCM_VALIDATE_VM (1, vm); vp = SCM_VM_DATA (vm); - vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest); - vp->last_ip = vp->ip; + + if (vp->fp) + { + vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest); + vp->last_ip = vp->ip; + } + else + { + vp->last_frame = SCM_BOOL_F; + } + + return vp->last_frame; } #undef FUNC_NAME diff --git a/src/vm_engine.h b/src/vm_engine.h index 76eb0671f..2026e3cdf 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -141,6 +141,13 @@ vp->fp = fp; \ } +#ifdef IP_PARANOIA +#define CHECK_IP() \ + do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0) +#else +#define CHECK_IP() +#endif + /* Get a local copy of the program's "object table" (i.e. the vector of external bindings that are referenced by the program), initialized by `load-program'. */ @@ -232,9 +239,9 @@ if (sp > stack_limit) \ goto vm_error_stack_overflow -#define CHECK_UNDERFLOW() \ - if (sp < stack_base) \ - goto vm_error_stack_underflow +#define CHECK_UNDERFLOW() \ + if (sp < stack_base) \ + goto vm_error_stack_underflow; #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) #define DROP() do { sp--; CHECK_UNDERFLOW (); } while (0) @@ -428,6 +435,7 @@ do { \ p[2] = dl; \ p[1] = SCM_BOOL_F; \ p[0] = external; \ + stack_base = p + 3; \ } #define FREE_FRAME() \ @@ -454,6 +462,9 @@ do { \ *sp++ = *p++; \ sp--; \ } \ + stack_base = fp ? \ + SCM_FRAME_UPPER_ADDRESS (fp) - 1 \ + : vp->stack_base; \ } #define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs] diff --git a/src/vm_system.c b/src/vm_system.c index c45126f04..179208e0a 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -60,6 +60,7 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0) POP (ret); FREE_FRAME (); SYNC_ALL (); + vp->ip = NULL; scm_dynwind_end (); return ret; } @@ -657,6 +658,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); CACHE_EXTERNAL (); + CHECK_IP (); NEXT; } diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index 0169b42c8..a2f209622 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -6,12 +6,15 @@ GUILE_VM = $(top_builddir)/src/guile-vm vm_test_files = \ t-basic-contructs.scm \ t-global-bindings.scm \ + t-catch.scm \ t-closure.scm \ t-closure2.scm \ t-closure3.scm \ t-do-loop.scm \ t-macros.scm \ t-macros2.scm \ + t-map.scm \ + t-or.scm \ t-proc-with-setter.scm \ t-values.scm \ t-records.scm \ diff --git a/testsuite/t-catch.scm b/testsuite/t-catch.scm new file mode 100644 index 000000000..9cc3e0e14 --- /dev/null +++ b/testsuite/t-catch.scm @@ -0,0 +1,10 @@ +;; Test that nonlocal exits of the VM work. + +(begin + (define (foo thunk) + (catch #t thunk (lambda args args))) + (foo + (lambda () + (let ((a 'one)) + (1+ a))))) + diff --git a/testsuite/t-map.scm b/testsuite/t-map.scm new file mode 100644 index 000000000..76bf1730f --- /dev/null +++ b/testsuite/t-map.scm @@ -0,0 +1,10 @@ +; Currently, map is a C function, so this is a way of testing that the +; VM is reentrant. + +(begin + + (define (square x) + (* x x)) + + (map (lambda (x) (square x)) + '(1 2 3))) diff --git a/testsuite/t-or.scm b/testsuite/t-or.scm new file mode 100644 index 000000000..cd29f1751 --- /dev/null +++ b/testsuite/t-or.scm @@ -0,0 +1,27 @@ +;; all the different permutations of or +(list + ;; not in tail position, no args + (or) + ;; not in tail position, one arg + (or 'what) + (or #f) + ;; not in tail position, two arg + (or 'what 'where) + (or #f 'where) + (or #f #f) + (or 'what #f) + ;; in tail position (within the lambdas) + ((lambda () + (or))) + ((lambda () + (or 'what))) + ((lambda () + (or #f))) + ((lambda () + (or 'what 'where))) + ((lambda () + (or #f 'where))) + ((lambda () + (or #f #f))) + ((lambda () + (or 'what #f))))