summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c14
-rw-r--r--module/language/cps/compile-bytecode.scm2
-rw-r--r--module/language/cps/effects-analysis.scm2
-rw-r--r--module/language/cps/primitives.scm1
-rw-r--r--module/language/cps/slot-allocation.scm2
-rw-r--r--module/language/cps/types.scm4
-rw-r--r--module/language/tree-il/compile-cps.scm7
-rw-r--r--module/system/vm/assembler.scm1
8 files changed, 28 insertions, 5 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 44bd2569b..3e068a18a 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 7fa5a003c..9e659e261 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 9c9334671..5b5bf1720 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 5074fb90c..80c01f0e2 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 ca8e32123..e54078027 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 ea89131a3..b99d0f4ab 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 2ef751b84..7b220b5a9 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 21f4353c8..8155ebe3a 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)