[Guile-commits] 19/41: Add bv-length instruction

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8464cc576c0fb9cf70a51450795338996cc785ce
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 19 22:12:04 2015 +0100

    Add bv-length instruction
    
    * libguile/vm-engine.c (bv-length): New instruction.
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/effects-analysis.scm (bv-length):
    * module/language/cps/primitives.scm (*instruction-aliases*):
    * module/language/cps/slot-allocation.scm (compute-var-representations):
    * module/language/cps/types.scm (bv-length):
    * module/language/tree-il/compile-cps.scm (convert): Add support for
      bv-length.
    * module/system/vm/assembler.scm: Export emit-bv-length.
---
 libguile/vm-engine.c                     |   14 +++++++++++++-
 module/language/cps/compile-bytecode.scm |    2 ++
 module/language/cps/effects-analysis.scm |    2 +-
 module/language/cps/primitives.scm       |    1 +
 module/language/cps/slot-allocation.scm  |    2 +-
 module/language/cps/types.scm            |    4 ++--
 module/language/tree-il/compile-cps.scm  |    7 +++++++
 module/system/vm/assembler.scm           |    1 +
 8 files changed, 28 insertions(+), 5 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 44bd256..3e068a1 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3341,7 +3341,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (145, unused_145, NULL, NOP)
+  /* bv-length dst:12 src:12
+   *
+   * Store the length of the bytevector in SRC in DST, as an untagged
+   * 64-bit integer.
+   */
+  VM_DEFINE_OP (145, bv_length, "bv-length", OP1 (X8_S12_S12) | OP_DST)
+    {
+      ARGS1 (bv);
+      VM_VALIDATE_BYTEVECTOR (bv, "bytevector-length");
+      SP_SET_U64 (dst, SCM_BYTEVECTOR_LENGTH (bv));
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (146, unused_146, NULL, NOP)
   VM_DEFINE_OP (147, unused_147, NULL, NOP)
   VM_DEFINE_OP (148, unused_148, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 7fa5a00..9e659e2 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -185,6 +185,8 @@
          (emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'f64->scm (src))
          (emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'bv-length (bv))
+         (emit-bv-length asm (from-sp dst) (from-sp (slot bv))))
         (($ $primcall 'bv-u8-ref (bv idx))
          (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
                          (from-sp (slot idx))))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 9c93346..5b5bf17 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -360,7 +360,7 @@ is or might be a read or a write to the same location as A."
 
 ;; Bytevectors.
 (define-primitive-effects
-  ((bytevector-length _)                                       &type-check)
+  ((bv-length _)                                               &type-check)
 
   ((bv-u8-ref bv n)                (&read-object &bytevector)  &type-check)
   ((bv-s8-ref bv n)                (&read-object &bytevector)  &type-check)
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index 5074fb9..80c01f0 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -41,6 +41,7 @@
     (modulo . mod)
     (variable-ref . box-ref)
     (variable-set! . box-set!)
+    (bytevector-length . bv-length)
     (bytevector-u8-ref . bv-u8-ref)
     (bytevector-u16-native-ref . bv-u16-ref)
     (bytevector-u32-native-ref . bv-u32-ref)
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index ca8e321..e540780 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -793,7 +793,7 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref
                                'fadd 'fsub 'fmul 'fdiv))
               (intmap-add representations var 'f64))
-             (($ $primcall (or 'scm->u64))
+             (($ $primcall (or 'scm->u64 'bv-length))
               (intmap-add representations var 'u64))
              (_
               (intmap-add representations var 'scm))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index ea89131..b99d0f4 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -713,8 +713,8 @@ minimum, and maximum."
 ;;; Bytevectors.
 ;;;
 
-(define-simple-type-checker (bytevector-length &bytevector))
-(define-type-inferrer (bytevector-length bv result)
+(define-simple-type-checker (bv-length &bytevector))
+(define-type-inferrer (bv-length bv result)
   (restrict! bv &bytevector 0 +inf.0)
   (define! result &exact-integer (max (&min bv) 0) (&max bv)))
 
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 2ef751b..7b220b5 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -576,6 +576,13 @@
                    (letk kbox ($kargs ('f64) (f64)
                                 ($continue k src ($primcall 'f64->scm (f64)))))
                    kbox))
+                ((bv-length)
+                 (with-cps cps
+                   (letv u64)
+                   (let$ k (adapt-arity k src out))
+                   (letk kbox ($kargs ('u64) (u64)
+                                ($continue k src ($primcall 'u64->scm (u64)))))
+                   kbox))
                 (else
                  (adapt-arity cps k src out))))
             (define (unbox-arg cps arg have-arg)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 21f4353..8155ebe 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -160,6 +160,7 @@
             emit-make-array
             (emit-scm->f64* . emit-scm->f64)
             (emit-f64->scm* . emit-f64->scm)
+            (emit-bv-length* . emit-bv-length)
             (emit-bv-u8-ref* . emit-bv-u8-ref)
             (emit-bv-s8-ref* . emit-bv-s8-ref)
             (emit-bv-u16-ref* . emit-bv-u16-ref)