summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-08-11 18:35:58 +0200
committerAndy Wingo <wingo@pobox.com>2008-08-11 18:35:58 +0200
commit7e4760e4133160e24cc15dba17cdeac3040eb080 (patch)
tree088db6283f78a51781bcd1ee4570bc7ca852c4d5
parent67c4505e7a1002d8bbb395d3d4d79e77250f737e (diff)
downloadguile-7e4760e4133160e24cc15dba17cdeac3040eb080.tar.gz
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.
-rw-r--r--module/system/il/compile.scm58
-rw-r--r--module/system/repl/repl.scm2
-rw-r--r--src/vm.c14
-rw-r--r--src/vm_engine.h17
-rw-r--r--src/vm_system.c2
-rw-r--r--testsuite/Makefile.am3
-rw-r--r--testsuite/t-catch.scm10
-rw-r--r--testsuite/t-map.scm10
-rw-r--r--testsuite/t-or.scm27
9 files changed, 110 insertions, 33 deletions
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)))))))))
((<ghil-or> 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)))))))))
((<ghil-begin> 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))))