diff options
author | Andy Wingo <wingo@pobox.com> | 2008-09-28 23:09:11 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-09-28 23:09:11 +0200 |
commit | 46d2d6f80ebbb18e787434c4bfe2031f6182f652 (patch) | |
tree | 4fa2c6589188d908a7488e83867ea9fc3f7d6dfc | |
parent | 877ffa3f9c8b1d58aedff2821ee1811c6f3c3622 (diff) | |
download | guile-46d2d6f80ebbb18e787434c4bfe2031f6182f652.tar.gz |
allocate variables that are set! on the heap
* module/system/il/ghil.scm (ghil-lookup): So, it turns out this function
needed to be split into three:
(ghil-var-is-bound?, ghil-var-for-ref!, ghil-var-for-set!): The
different facets of ghil-lookup. Amply commented in the source. The
difference being that we now allocate variables that are set! on the
heap, so that other continuations see their possibly-modified values.
(force-heap-allocation!): New helper.
* testsuite/Makefile.am:
* testsuite/t-call-cc.scm: New test, that variables that are set! are
allocated on the heap, so that subsequent modifications are still
seen by the continuation. The test was distilled from test 7.3 in
r5rs_pitfall.test.
-rw-r--r-- | module/language/scheme/translate.scm | 8 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 77 | ||||
-rw-r--r-- | testsuite/Makefile.am | 1 | ||||
-rw-r--r-- | testsuite/t-call-cc.scm | 16 |
4 files changed, 78 insertions, 24 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 799e67c23..87057d89e 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -102,7 +102,7 @@ (make-ghil-call e l (retrans head) tail))))))) ((symbol? x) - (make-ghil-ref e l (ghil-lookup e x))) + (make-ghil-ref e l (ghil-var-for-ref! e x))) ;; fixme: non-self-quoting objects like #<foo> (else @@ -146,7 +146,7 @@ ;; (define NAME VAL) ((,name ,val) (guard (symbol? name) (ghil-toplevel-env? (ghil-env-parent e))) - (make-ghil-define e l (ghil-define (ghil-env-parent e) name) + (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name) (maybe-name-value! (retrans val) name))) ;; (define (NAME FORMALS...) BODY...) (((,name . ,formals) . ,body) (guard (symbol? name)) @@ -156,7 +156,7 @@ (set! ;; (set! NAME VAL) ((,name ,val) (guard (symbol? name)) - (make-ghil-set e l (ghil-lookup e name) (retrans val))) + (make-ghil-set e l (ghil-var-for-set! e name) (retrans val))) ;; (set! (NAME ARGS...) VAL) (((,name . ,args) ,val) (guard (symbol? name)) @@ -311,7 +311,7 @@ ((,proc ,arg1 . ,args) (let ((args (cons (retrans arg1) (map retrans args)))) (cond ((and (symbol? proc) - (not (ghil-lookup e proc #f)) + (not (ghil-var-is-bound? e proc)) (and=> (module-variable (current-module) proc) (lambda (var) (and (variable-bound? var) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 1398bd17f..92abfc343 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -94,7 +94,8 @@ <ghil-env> make-ghil-env ghil-env? ghil-env-parent ghil-env-table ghil-env-variables - ghil-env-add! ghil-lookup ghil-define + ghil-env-add! + ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define! call-with-ghil-environment call-with-ghil-bindings)) @@ -165,42 +166,78 @@ (define (ghil-env-remove! env var) (apopq! (ghil-var-name var) (ghil-env-table env))) +(define (force-heap-allocation! var) + (set! (ghil-var-kind var) 'external)) + + ;;; ;;; Public interface ;;; -;; ghil-lookup: find out where a variable will be stored at runtime. +;; The following four functions used to be one, in ghil-lookup. Now they +;; are four, to reflect the different intents. A bit of duplication, but +;; that's OK. The common current is to find out where a variable will be +;; stored at runtime. ;; -;; First searches the lexical environments. If the variable is not in -;; the innermost environment, make sure the variable is marked as being -;; "external" so that it goes on the heap. +;; These functions first search the lexical environments. If the +;; variable is not in the innermost environment, make sure the variable +;; is marked as being "external" so that it goes on the heap. If the +;; variable is being modified (via a set!), also make sure it's on the +;; heap, so that other continuations see the changes to the var. ;; ;; If the variable is not found lexically, it is a toplevel variable, ;; which will be looked up at runtime with respect to the module that ;; was current when the lambda was bound, at runtime. The variable will ;; be resolved when it is first used. -(define (ghil-lookup env sym . define?) +(define (ghil-var-is-bound? env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (assoc-ref table key))) + ((<ghil-env> parent table variables) + (and (not (assq-ref table sym)) + (loop parent)))))) + +(define (ghil-var-for-ref! env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'module))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (cond + ((assq-ref table sym) + => (lambda (var) + (or (eq? e env) + (force-heap-allocation! var)) + var)) + (else + (loop parent))))))) + +(define (ghil-var-for-set! env sym) (let loop ((e env)) (record-case e ((<ghil-toplevel-env> table) (let ((key (cons (module-name (current-module)) sym))) (or (assoc-ref table key) - (and (or (null? define?) - (car define?)) - (let ((var (make-ghil-var (car key) (cdr key) 'module))) - (apush! key var (ghil-toplevel-env-table e)) - var))))) + (let ((var (make-ghil-var (car key) (cdr key) 'module))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) ((<ghil-env> parent table variables) - (let ((found (assq-ref table sym))) - (if found - (begin - (if (not (eq? e env)) - (set! (ghil-var-kind found) 'external)) - found) - (loop parent))))))) - -(define (ghil-define toplevel sym) + (cond + ((assq-ref table sym) + => (lambda (var) + (force-heap-allocation! var) + var)) + (else + (loop parent))))))) + +(define (ghil-var-define! toplevel sym) (let ((key (cons (module-name (current-module)) sym))) (or (assoc-ref (ghil-toplevel-env-table toplevel) key) (let ((var (make-ghil-var (car key) (cdr key) 'module))) diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index 59ef56587..6ff48b5de 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -7,6 +7,7 @@ vm_test_files = \ t-basic-contructs.scm \ t-global-bindings.scm \ t-catch.scm \ + t-call-cc.scm \ t-closure.scm \ t-closure2.scm \ t-closure3.scm \ diff --git a/testsuite/t-call-cc.scm b/testsuite/t-call-cc.scm new file mode 100644 index 000000000..05e4de98c --- /dev/null +++ b/testsuite/t-call-cc.scm @@ -0,0 +1,16 @@ +(let ((set-counter2 #f)) + (define (get-counter2) + (call/cc + (lambda (k) + (set! set-counter2 k) + 1))) + (define (loop counter1) + (let ((counter2 (get-counter2))) + (set! counter1 (1+ counter1)) + (cond ((not (= counter1 counter2)) + (error "bad call/cc behaviour" counter1 counter2)) + ((> counter1 10) + #t) + (else + (set-counter2 (1+ counter2)))))) + (loop 0)) |