From 46d2d6f80ebbb18e787434c4bfe2031f6182f652 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 Sep 2008 23:09:11 +0200 Subject: [PATCH] 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. --- module/language/scheme/translate.scm | 8 +-- module/system/il/ghil.scm | 75 +++++++++++++++++++++------- testsuite/Makefile.am | 1 + testsuite/t-call-cc.scm | 16 ++++++ 4 files changed, 77 insertions(+), 23 deletions(-) create mode 100644 testsuite/t-call-cc.scm 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 # (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 @@ 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 + (( table) + (let ((key (cons (module-name (current-module)) sym))) + (assoc-ref table key))) + (( 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 (( 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)))) (( 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))))))) + (cond + ((assq-ref table sym) + => (lambda (var) + (or (eq? e env) + (force-heap-allocation! var)) + var)) + (else + (loop parent))))))) -(define (ghil-define toplevel sym) +(define (ghil-var-for-set! env sym) + (let loop ((e env)) + (record-case e + (( 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)))) + (( parent table variables) + (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))