diff options
-rw-r--r-- | libguile/vm-engine.c | 14 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 2 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 1 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 2 | ||||
-rw-r--r-- | module/language/cps/types.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 7 | ||||
-rw-r--r-- | 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 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) |