guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 01/02: `define!' instruction returns the variable


From: Andy Wingo
Subject: [Guile-commits] 01/02: `define!' instruction returns the variable
Date: Tue, 21 Jun 2016 20:46:46 +0000 (UTC)

wingo pushed a commit to branch master
in repository guile.

commit f1c043440312b5504ba03debeaba25c9ac1a3873
Author: Andy Wingo <address@hidden>
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
 
address@hidden Instruction {} define! s12:@var{sym} s12:@var{val}
address@hidden 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))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]