summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-09-28 23:09:11 +0200
committerAndy Wingo <wingo@pobox.com>2008-09-28 23:09:11 +0200
commit46d2d6f80ebbb18e787434c4bfe2031f6182f652 (patch)
tree4fa2c6589188d908a7488e83867ea9fc3f7d6dfc
parent877ffa3f9c8b1d58aedff2821ee1811c6f3c3622 (diff)
downloadguile-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.scm8
-rw-r--r--module/system/il/ghil.scm77
-rw-r--r--testsuite/Makefile.am1
-rw-r--r--testsuite/t-call-cc.scm16
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))