From 7e4760e4133160e24cc15dba17cdeac3040eb080 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Aug 2008 18:35:58 +0200 Subject: [PATCH] fix bug in compilation of `and' and `or'; more robust underflow detection. * module/system/il/compile.scm (codegen): Rewrite handling of `and' and `or' ghil compilation, because it was broken if drop was #t. Tricky bug, this one! Took me days to track down! * module/system/repl/repl.scm: Export call-with-backtrace, which probably should go in some other file. * src/vm.c (scm_vm_save_stack): Handle the fp==0 case for errors before we have a frame. * src/vm_engine.h (NEW_FRAME, FREE_FRAME): Stricter underflow checking, raising the stack base to the return address, in an attempt to prevent inadvertant stack smashing (the symptom of the and/or miscompilation bug). (CHECK_IP): A check that the current IP is within the bounds of the current program. Not normally compiled in. Perhaps it should be? * src/vm_system.c (halt): Set vp->ip to NULL. Paranoia, I know. (return): Call CHECK_IP(), if such a thing is compiled in. * testsuite/Makefile.am (vm_test_files): * testsuite/t-catch.scm: * testsuite/t-map.scm: * testsuite/t-or.scm: New tests. --- module/system/il/compile.scm | 58 +++++++++++++++++++----------------- module/system/repl/repl.scm | 2 +- src/vm.c | 14 +++++++-- src/vm_engine.h | 17 +++++++++-- src/vm_system.c | 2 ++ testsuite/Makefile.am | 3 ++ testsuite/t-catch.scm | 10 +++++++ testsuite/t-map.scm | 10 +++++++ testsuite/t-or.scm | 27 +++++++++++++++++ 9 files changed, 110 insertions(+), 33 deletions(-) create mode 100644 testsuite/t-catch.scm create mode 100644 testsuite/t-map.scm create mode 100644 testsuite/t-or.scm 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)))) -- 2.20.1