From 9cc649b880fe81ff4b2dd1929beb45ea313dee42 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 19 May 2008 17:46:05 +0200 Subject: [PATCH] Add instructions for doing very late binding Fixes the mutually-recursive toplevel definitions case. This could be fixed by rewriting bodies as letrecs, as r6 does, but that's not really repl-compatible. * module/system/il/ghil.scm (ghil-lookup): Ok, if we can't locate a variable, mark it as unresolved. * module/system/il/compile.scm (make-glil-var): Compile unresolved variables as objects. * module/system/il/glil.scm: Add definition. * module/system/vm/assemble.scm (codegen): And, finally, when we see a object, allocate a slot for it in the object vector, setting it to a symbol. Add a new pair of instructions to resolve that symbol to a variable at the last minute. * src/vm_loader.c (load-number): Bugfix: the radix argument should be SCM_UNDEFINED in order to default to 10. (late-bind): Add an unresolved symbol to the object vector. Could be replaced with load-symbol I guess. * src/vm_system.c (late-variable-ref, late-variable-set): New instructions to do late symbol binding. * testsuite/Makefile.am (vm_test_files): * testsuite/t-mutual-toplevel-defines.scm: New test, failing for some reason involving the core even? and odd? definitions. --- module/system/il/compile.scm | 2 ++ module/system/il/ghil.scm | 10 +++--- module/system/il/glil.scm | 4 +++ module/system/vm/assemble.scm | 17 ++++++++++ src/vm_loader.c | 15 ++++++++- src/vm_system.c | 45 +++++++++++++++++++++++++ testsuite/Makefile.am | 3 +- testsuite/run-vm-tests.scm | 6 ++-- testsuite/t-mutual-toplevel-defines.scm | 8 +++++ 9 files changed, 99 insertions(+), 11 deletions(-) create mode 100644 testsuite/t-mutual-toplevel-defines.scm diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 51b914b6a..e9636503b 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -103,6 +103,8 @@ (let ((env (ghil-var-env var))) (make-glil-module op (and env (ghil-mod-module (ghil-env-mod env))) (ghil-var-name var)))) + ((unresolved) + (make-glil-late-bound op (ghil-var-name var))) (else (error "Unknown kind of variable:" var)))) (define (codegen ghil) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 0a65f833f..e5029e102 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -224,12 +224,10 @@ (make-ghil-var found-env sym 'module))) (else ;; a free variable that we have not resolved - (if (not (module-locally-bound? module sym)) - ;; For the benefit of repl compilation, that - ;; doesn't compile modules all-at-once, don't warn - ;; if we find the symbol locally. - (warn "unresolved variable during compilation:" sym)) - (make-ghil-var #f sym 'module)))) + (warn "unresolved variable during compilation:" sym) + (let ((var (make-ghil-var #f sym 'unresolved))) + (apush! sym var table) + var)))) (( mod parent table variables) (let ((found (assq-ref table sym))) (if found diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index 3ffb6a754..6a3ec4c17 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -54,6 +54,9 @@ make-glil-module glil-module? glil-module-op glil-module-module glil-module-index + make-glil-late-bound glil-late-bound? + glil-late-bound-op glil-late-bound-name + make-glil-label glil-label? glil-label-label @@ -80,6 +83,7 @@ ( op index) ( op depth index) ( op module name) + ( op name) ;; Controls ( label) ( inst label) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index cbb307b92..3197f7122 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -44,6 +44,7 @@ (define-record ( parent nexts closure?)) (define-record ( id)) (define-record ( module name)) +(define-record ( name)) (define-record ( module name)) (define-record ( vars bytes meta objs closure?)) @@ -158,6 +159,20 @@ (push-object! (make-vdefine :module module :name name)) (push-code! '(variable-set))))) + (( op name) + (let* ((var (make-vlate-bound :name name)) + (i (cond ((object-assoc var object-alist) => cdr) + (else + (let ((i (length object-alist))) + (set! object-alist (acons var i object-alist)) + i))))) + (case op + ((ref) + (push-code! `(late-variable-ref ,i))) + ((set) + (push-code! `(late-variable-set ,i))) + (else (error "unknown late bound" op name))))) + (( label) (set! label-alist (assq-set! label-alist label (current-address)))) @@ -263,6 +278,8 @@ (( module name) ;; FIXME: dump module (push-code! `(define ,(symbol->string name)))) + (( name) + (push-code! `(late-bind ,(symbol->string name)))) (( id) (push-code! `(load-module ,id))) (else diff --git a/src/vm_loader.c b/src/vm_loader.c index a28d44b25..d8bf554a8 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -64,7 +64,7 @@ VM_DEFINE_LOADER (load_number, "load-number") FETCH_LENGTH (len); PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len), - SCM_UNSPECIFIED /* radix = 10 */)); + SCM_UNDEFINED /* radix = 10 */)); /* Was: scm_istring2number (ip, len, 10)); */ ip += len; NEXT; @@ -215,6 +215,19 @@ VM_DEFINE_LOADER (define, "define") NEXT; } +VM_DEFINE_LOADER (late_bind, "late-bind") +{ + SCM sym; + size_t len; + + FETCH_LENGTH (len); + sym = scm_from_locale_symboln ((char *)ip, len); + ip += len; + + PUSH (sym); + NEXT; +} + /* Local Variables: c-file-style: "gnu" diff --git a/src/vm_system.c b/src/vm_system.c index 4dcafb113..6daa818a7 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -257,6 +257,28 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1) +{ + register unsigned objnum = FETCH (); + SCM x; + CHECK_OBJECT (objnum); + x = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (x)) + { + x = scm_lookup (x); /* might longjmp */ + OBJECT_SET (objnum, x); + if (!VARIABLE_BOUNDP (x)) + { + err_args = SCM_LIST1 (x); + goto vm_error_unbound; + } + } + + PUSH (VARIABLE_REF (x)); + NEXT; +} + /* set */ VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0) @@ -289,6 +311,29 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0) +{ + register unsigned objnum = FETCH (); + SCM x; + CHECK_OBJECT (objnum); + x = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (x)) + { + x = scm_lookup (x); /* might longjmp */ + OBJECT_SET (objnum, x); + if (!VARIABLE_BOUNDP (x)) + { + err_args = SCM_LIST1 (x); + goto vm_error_unbound; + } + } + + VARIABLE_SET (x, *sp); + DROP (); + NEXT; +} + /* * branch and jump diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index a3e8921c2..c12e51622 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -15,7 +15,8 @@ vm_test_files = \ t-proc-with-setter.scm \ t-values.scm \ t-records.scm \ - t-match.scm + t-match.scm \ + t-mutual-toplevel-defines.scm EXTRA_DIST = run-vm-tests.scm $(vm_test_files) diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm index 64568b171..19cb9e1cf 100644 --- a/testsuite/run-vm-tests.scm +++ b/testsuite/run-vm-tests.scm @@ -74,9 +74,9 @@ equal in the sense of @var{equal?}." (format #t "running `~a'... " file) (if (catch #t (lambda () - (equal? (compile/run-test-from-file file) - (eval (fetch-sexp-from-file file) - (interaction-environment)))) + (equal? (pk (compile/run-test-from-file file)) + (pk (eval (fetch-sexp-from-file file) + (interaction-environment))))) (lambda (key . args) (format #t "[~a/~a] " key args) #f)) diff --git a/testsuite/t-mutual-toplevel-defines.scm b/testsuite/t-mutual-toplevel-defines.scm new file mode 100644 index 000000000..795c74423 --- /dev/null +++ b/testsuite/t-mutual-toplevel-defines.scm @@ -0,0 +1,8 @@ +(define (even? x) + (or (zero? x) + (not (odd? (1- x))))) + +(define (odd? x) + (not (even? (1- x)))) + +(even? 20) -- 2.20.1