wingo pushed a commit to branch master in repository guile. commit f1c043440312b5504ba03debeaba25c9ac1a3873 Author: Andy Wingo <wi...@pobox.com> Date: Tue Jun 21 22:29:55 2016 +0200
`define!' instruction returns the variable * doc/ref/vm.texi (Top-Level Environment Instructions): Update documentation. * libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump, sadly. * module/system/vm/assembler.scm (*bytecode-minor-version*): Bump. * libguile/vm-engine.c (define!): Change to store variable in dst slot. * module/language/tree-il/compile-cps.scm (convert): * module/language/cps/compile-bytecode.scm (compile-function): Adapt to define! change. * module/language/cps/effects-analysis.scm (current-module): Fix define! effects. Incidentally here was the bug: in Guile 2.2 you can't have effects on different object kinds in one instruction, without reverting to &unknown-memory-kinds. * test-suite/tests/compiler.test ("regression tests"): Add a test. --- doc/ref/vm.texi | 4 ++-- libguile/_scm.h | 2 +- libguile/vm-engine.c | 13 ++++++++----- module/language/cps/compile-bytecode.scm | 4 ++-- module/language/cps/effects-analysis.scm | 2 +- module/language/tree-il/compile-cps.scm | 5 ++++- module/system/vm/assembler.scm | 2 +- test-suite/tests/compiler.test | 8 ++++++++ 8 files changed, 27 insertions(+), 13 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 70aa364..4505a01 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -674,9 +674,9 @@ found. If @var{bound?} is true, an error will be signalled if the variable is unbound. @end deftypefn -@deftypefn Instruction {} define! s12:@var{sym} s12:@var{val} +@deftypefn Instruction {} define! s12:@var{dst} s12:@var{sym} Look up a binding for @var{sym} in the current module, creating it if -necessary. Set its value to @var{val}. +necessary. Store that variable to @var{dst}. @end deftypefn @deftypefn Instruction {} toplevel-box s24:@var{dst} r32:@var{var-offset} r32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} diff --git a/libguile/_scm.h b/libguile/_scm.h index 2792fd2..60ad082 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -268,7 +268,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 8 +#define SCM_OBJCODE_MINOR_VERSION 9 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 0978636..4b5b70b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1950,18 +1950,21 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (2); } - /* define! sym:12 val:12 + /* define! dst:12 sym:12 * * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (66, define, "define!", OP1 (X8_S12_S12)) + VM_DEFINE_OP (66, define, "define!", OP1 (X8_S12_S12) | OP_DST) { - scm_t_uint16 sym, val; - UNPACK_12_12 (op, sym, val); + scm_t_uint16 dst, sym; + SCM var; + UNPACK_12_12 (op, dst, sym); SYNC_IP (); - scm_define (SP_REF (sym), SP_REF (val)); + var = scm_module_ensure_local_variable (scm_current_module (), + SP_REF (sym)); CACHE_SP (); + SP_SET (dst, var); NEXT (1); } diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ea5b59f..7c69fa6 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -150,6 +150,8 @@ (emit-cached-module-box asm (from-sp dst) (constant mod) (constant name) (constant public?) (constant bound?))) + (($ $primcall 'define! (sym)) + (emit-define! asm (from-sp dst) (from-sp (slot sym)))) (($ $primcall 'resolve (name bound?)) (emit-resolve asm (from-sp dst) (constant bound?) (from-sp (slot name)))) @@ -312,8 +314,6 @@ (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value)))) (($ $primcall 'set-cdr! (pair value)) (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value)))) - (($ $primcall 'define! (sym value)) - (emit-define! asm (from-sp (slot sym)) (from-sp (slot value)))) (($ $primcall 'push-fluid (fluid val)) (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val)))) (($ $primcall 'pop-fluid ()) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 70344a2..5698fcd 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -418,7 +418,7 @@ is or might be a read or a write to the same location as A." ((resolve name bound?) (&read-object &module) &type-check) ((cached-toplevel-box scope name bound?) &type-check) ((cached-module-box mod name public? bound?) &type-check) - ((define! name val) (&read-object &module) (&write-object &box))) + ((define! name) (&read-object &module))) ;; Numbers. (define-primitive-effects diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 0b9c834..3443d76 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -493,9 +493,12 @@ (lambda (cps val) (with-cps cps (let$ k (adapt-arity k src 0)) + (letv box) + (letk kset ($kargs ('box) (box) + ($continue k src ($primcall 'box-set! (box val))))) ($ (with-cps-constants ((name name)) (build-term - ($continue k src ($primcall 'define! (name val)))))))))) + ($continue kset src ($primcall 'define! (name)))))))))) (($ <call> src proc args) (convert-args cps (cons proc args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index fb7f074..9fc5349 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1754,7 +1754,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 8) +(define *bytecode-minor-version* 9) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 02f2a54..b294912 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -202,3 +202,11 @@ (vector ,@(map (lambda (n) `(identity ,n)) (iota 300)))))) (list->vector (iota 300))))) + +(with-test-prefix "regression tests" + (pass-if-equal "#18583" 1 + (compile + '(begin + (define x (list 1)) + (define x (car x)) + x))))