diff options
author | Andy Wingo <wingo@pobox.com> | 2011-11-11 16:27:30 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-11-11 16:27:30 +0100 |
commit | 16371014d6231394dbfc9c5cc9dfcceabd8bc234 (patch) | |
tree | 563fbb1c6f73ea76226122043b712ed6645b5908 | |
parent | b86b70feced7d2be203be0738e1bab8d1e81a11e (diff) | |
parent | 39c5363b4fbd32f1c895e8fa8b0c8dd067907947 (diff) | |
download | guile-16371014d6231394dbfc9c5cc9dfcceabd8bc234.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
-rw-r--r-- | libguile/bitvectors.c | 6 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 22 | ||||
-rw-r--r-- | test-suite/tests/bitvectors.test | 21 | ||||
-rw-r--r-- | test-suite/tests/gc.test | 28 |
4 files changed, 62 insertions, 15 deletions
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 12dd13637..5b5a1b8e2 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -568,7 +568,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, "\n" "If @var{kv} is a bit vector, then those entries where it has\n" "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" - "@var{kv} and @var{v} must be the same length. When @var{obj}\n" + "@var{v} must be at least as long as @var{kv}. When @var{obj}\n" "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" "\n" @@ -611,10 +611,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, ssize_t kv_inc; const scm_t_uint32 *kv_bits; - kv_bits = scm_bitvector_elements (v, &kv_handle, + kv_bits = scm_bitvector_elements (kv, &kv_handle, &kv_off, &kv_len, &kv_inc); - if (v_len != kv_len) + if (v_len < kv_len) scm_misc_error (NULL, "bit vectors must have equal length", SCM_EOL); diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 28c31f387..31e9a70b5 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -240,6 +240,24 @@ (if (eq? context 'tail) (emit-code #f (make-glil-call 'return 1))))) + ;; After lexical binding forms in non-tail context, call this + ;; function to clear stack slots, allowing their previous values to + ;; be collected. + (define (clear-stack-slots context syms) + (case context + ((push drop) + (for-each (lambda (v) + (and=> + ;; Can be #f if the var is labels-allocated. + (hashq-ref allocation v) + (lambda (h) + (pmatch (hashq-ref h self) + ((#t _ . ,n) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-lexical #t #f 'set n))) + (,loc (error "bad let var allocation" x loc)))))) + syms)))) + (record-case x ((<void>) (case context @@ -748,6 +766,7 @@ (,loc (error "bad let var allocation" x loc)))) (reverse gensyms)) (comp-tail body) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind))) ((<letrec> src in-order? names gensyms vals body) @@ -780,6 +799,7 @@ (,loc (error "bad letrec var allocation" x loc)))) (reverse gensyms)))) (comp-tail body) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind))) ((<fix> src names gensyms vals body) @@ -868,6 +888,7 @@ (comp-tail body) (if new-RA (emit-label new-RA)) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind)))) ((<let-values> src exp body) @@ -893,6 +914,7 @@ (,loc (error "bad let-values var allocation" x loc)))) (reverse gensyms)) (comp-tail body) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind)))))) ;; much trickier than i thought this would be, at first, due to the need diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test index 9833b3bfd..c16fb4d49 100644 --- a/test-suite/tests/bitvectors.test +++ b/test-suite/tests/bitvectors.test @@ -1,6 +1,6 @@ ;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*- ;;;; -;;;; Copyright 2010 Free Software Foundation, Inc. +;;;; Copyright 2010, 2011 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -55,5 +55,20 @@ (uniform-vector-set! bv 0 #t) (pass-if (eqv? (uniform-vector-ref bv 0) #t))))) - - +(with-test-prefix "bit-set*!" + (pass-if "#t" + (let ((v (bitvector #t #t #f #f))) + (bit-set*! v #*1010 #t) + (equal? v #*1110))) + (pass-if "#f" + (let ((v (bitvector #t #t #f #f))) + (bit-set*! v #*1010 #f) + (equal? v #*0100))) + (pass-if "#t, shorter" + (let ((v (bitvector #t #t #f #f))) + (bit-set*! v #*101 #t) + (equal? v #*1110))) + (pass-if "#f, shorter" + (let ((v (bitvector #t #t #f #f))) + (bit-set*! v #*101 #f) + (equal? v #*0100)))) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 57643e825..25dc5779d 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -16,8 +16,10 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(use-modules (ice-9 documentation) - (test-suite lib)) +(define-module (test-suite tests gc) + #:use-module (ice-9 documentation) + #:use-module (test-suite lib) + #:use-module ((system base compile) #:select (compile))) ;;; @@ -62,10 +64,8 @@ (add-hook! after-gc-hook thunk) (gc) (remove-hook! after-gc-hook thunk) - foo))) + foo)) - -(with-test-prefix "gc" (pass-if "Unused modules are removed" (let* ((guard (make-guardian)) (total 1000)) @@ -76,12 +76,22 @@ (stack-cleanup 20) (gc) - (gc) ;; twice: have to kill the weak vectors. - (gc) ;; thrice: because the test doesn't succeed with only - ;; one gc round. not sure why. + (gc) ;; twice: have to kill the weak vectors. + (gc) ;; thrice: because the test doesn't succeed with only + ;; one gc round. not sure why. (= (let lp ((i 0)) (if (guard) (lp (1+ i)) i)) - total)))) + total))) + + (pass-if "Lexical vars are collectable" + (procedure? + (compile + '(begin + (define guardian (make-guardian)) + (let ((f (lambda () (display "test\n")))) + (guardian f)) + (gc)(gc)(gc) + (guardian)))))) |