diff --git a/libguile/instructions.c b/libguile/instructions.c index 49b07d1dc..29e60983b 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -54,6 +54,8 @@ SCM_SYMBOL (sym_bang, "!"); M(BF32) /* Immediate double, low bits. */ \ M(AU32) /* Immediate uint64, high bits. */ \ M(BU32) /* Immediate uint64, low bits. */ \ + M(AS32) /* Immediate int64, high bits. */ \ + M(BS32) /* Immediate int64, low bits. */ \ M(N32) /* Non-immediate. */ \ M(R32) /* Scheme value (indirected). */ \ M(L32) /* Label. */ \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index b6d656b4e..ed39fed5c 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2957,62 +2957,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the item at byte offset IDX in the bytevector SRC, and store * it in DST. All accesses use native endianness. */ -#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ +#define BV_REF(stem, type, size, slot) \ do { \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - RETURN (SCM_I_MAKINUM (*int_ptr)); \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \ - } \ - } while (0) - -#define BV_INT_REF(stem, type, size) \ - do { \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - { \ - scm_t_ ## type x = *int_ptr; \ - if (SCM_FIXABLE (x)) \ - RETURN (SCM_I_MAKINUM (x)); \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_from_ ## type (x)); \ - } \ - } \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \ - } \ - } while (0) - -#define BV_FLOAT_REF(stem, fn_stem, type, size) \ - do { \ - const type *float_ptr; \ + type result; \ scm_t_uint8 dst, src, idx; \ SCM bv; \ scm_t_uint64 c_idx; \ @@ -3021,63 +2968,45 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ \ - if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ - && (c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size) \ - && (ALIGNED_P (float_ptr, type)))) \ - { \ - SP_SET_F64 (dst, *float_ptr); \ - NEXT (1); \ - } \ - else \ - { \ - SCM scm_idx, val; \ - SYNC_IP (); \ - scm_idx = scm_from_uint64 (c_idx); \ - val = scm_bytevector_ ## fn_stem ## _native_ref (bv, scm_idx); \ - SP_SET_F64 (dst, scm_to_double (val)); \ - NEXT (1); \ - } \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-ref", c_idx); \ + \ + memcpy (&result, SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, size); \ + SP_SET_ ## slot (dst, result); \ + NEXT (1); \ } while (0) VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (u8, u8, uint8, 1); + BV_REF (u8, scm_t_uint8, 1, U64); VM_DEFINE_OP (117, bv_s8_ref, "bv-s8-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (s8, s8, int8, 1); + BV_REF (s8, scm_t_int8, 1, S64); VM_DEFINE_OP (118, bv_u16_ref, "bv-u16-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); + BV_REF (u16, scm_t_uint16, 2, U64); VM_DEFINE_OP (119, bv_s16_ref, "bv-s16-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); + BV_REF (s16, scm_t_int16, 2, S64); VM_DEFINE_OP (120, bv_u32_ref, "bv-u32-ref", OP1 (X8_S8_S8_S8) | OP_DST) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); -#else - BV_INT_REF (u32, uint32, 4); -#endif + BV_REF (u32, scm_t_uint32, 4, U64); VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); -#else - BV_INT_REF (s32, int32, 4); -#endif + BV_REF (s32, scm_t_int32, 4, S64); VM_DEFINE_OP (122, bv_u64_ref, "bv-u64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_INT_REF (u64, uint64, 8); + BV_REF (u64, scm_t_uint64, 8, U64); VM_DEFINE_OP (123, bv_s64_ref, "bv-s64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_INT_REF (s64, int64, 8); + BV_REF (s64, scm_t_int64, 8, S64); VM_DEFINE_OP (124, bv_f32_ref, "bv-f32-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FLOAT_REF (f32, ieee_single, float, 4); + BV_REF (f32, float, 4, F64); VM_DEFINE_OP (125, bv_f64_ref, "bv-f64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FLOAT_REF (f64, ieee_double, double, 8); + BV_REF (f64, double, 8, F64); /* bv-u8-set! dst:8 idx:8 src:8 * bv-s8-set! dst:8 idx:8 src:8 @@ -3093,133 +3022,89 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Store SRC into the bytevector DST at byte offset IDX. Multibyte * values are written using native endianness. */ -#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ +#define BV_BOUNDED_SET(stem, type, min, max, size, slot_type, slot) \ do { \ - scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i, j = 0; \ - SCM bv, scm_idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)) \ - && (SCM_I_INUMP (val)) \ - && ((j = SCM_I_INUM (val)) >= min) \ - && (j <= max))) \ - *int_ptr = (scm_t_ ## type) j; \ - else \ - { \ - SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \ - } \ - NEXT (1); \ - } while (0) - -#define BV_INT_SET(stem, type, size) \ - do { \ - scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i; \ - SCM bv, scm_idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - *int_ptr = scm_to_ ## type (val); \ - else \ - { \ - SYNC_IP (); \ - scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \ - } \ - NEXT (1); \ - } while (0) - -#define BV_FLOAT_SET(stem, fn_stem, type, size) \ - do { \ + scm_t_ ## slot_type slot_val; \ + type val; \ scm_t_uint8 dst, idx, src; \ SCM bv; \ scm_t_uint64 c_idx; \ - double val; \ - type *float_ptr; \ - \ UNPACK_8_8_8 (op, dst, idx, src); \ bv = SP_REF (dst); \ c_idx = SP_REF_U64 (idx); \ - val = SP_REF_F64 (src); \ + slot_val = SP_REF_ ## slot (src); \ + \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ + \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ \ - if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ - && c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size \ - && ALIGNED_P (float_ptr, type))) \ - *float_ptr = val; \ - else \ - { \ - SCM boxed_idx, boxed_val; \ - boxed_idx = scm_from_uint64 (c_idx); \ - boxed_val = scm_from_double (val); \ - SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, boxed_idx, \ - boxed_val); \ - } \ + if (SCM_UNLIKELY (slot_val < min) || SCM_UNLIKELY (slot_val > max)) \ + vm_error_out_of_range_ ## slot_type ("bv-" #stem "-set!", \ + slot_val); \ + \ + val = slot_val; \ + memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ + NEXT (1); \ + } while (0) + +#define BV_SET(stem, type, size, slot) \ + do { \ + type val; \ + scm_t_uint8 dst, idx, src; \ + SCM bv; \ + scm_t_uint64 c_idx; \ + UNPACK_8_8_8 (op, dst, idx, src); \ + bv = SP_REF (dst); \ + c_idx = SP_REF_U64 (idx); \ + val = SP_REF_ ## slot (src); \ + \ + VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ + \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ + \ + memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ NEXT (1); \ } while (0) VM_DEFINE_OP (126, bv_u8_set, "bv-u8-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); + BV_BOUNDED_SET (u8, scm_t_uint8, + 0, SCM_T_UINT8_MAX, 1, uint64, U64); VM_DEFINE_OP (127, bv_s8_set, "bv-s8-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); + BV_BOUNDED_SET (s8, scm_t_int8, + SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1, int64, S64); VM_DEFINE_OP (128, bv_u16_set, "bv-u16-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); + BV_BOUNDED_SET (u16, scm_t_uint16, + 0, SCM_T_UINT16_MAX, 2, uint64, U64); VM_DEFINE_OP (129, bv_s16_set, "bv-s16-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); + BV_BOUNDED_SET (s16, scm_t_int16, + SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2, int64, S64); VM_DEFINE_OP (130, bv_u32_set, "bv-u32-set!", OP1 (X8_S8_S8_S8)) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); -#else - BV_INT_SET (u32, uint32, 4); -#endif + BV_BOUNDED_SET (u32, scm_t_uint32, + 0, SCM_T_UINT32_MAX, 4, uint64, U64); VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8)) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); -#else - BV_INT_SET (s32, int32, 4); -#endif + BV_BOUNDED_SET (s32, scm_t_int32, + SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4, int64, S64); VM_DEFINE_OP (132, bv_u64_set, "bv-u64-set!", OP1 (X8_S8_S8_S8)) - BV_INT_SET (u64, uint64, 8); + BV_SET (u64, scm_t_uint64, 8, U64); VM_DEFINE_OP (133, bv_s64_set, "bv-s64-set!", OP1 (X8_S8_S8_S8)) - BV_INT_SET (s64, int64, 8); + BV_SET (s64, scm_t_int64, 8, S64); VM_DEFINE_OP (134, bv_f32_set, "bv-f32-set!", OP1 (X8_S8_S8_S8)) - BV_FLOAT_SET (f32, ieee_single, float, 4); + BV_SET (f32, float, 4, F64); VM_DEFINE_OP (135, bv_f64_set, "bv-f64-set!", OP1 (X8_S8_S8_S8)) - BV_FLOAT_SET (f64, ieee_double, double, 8); + BV_SET (f6, double, 8, F64); /* scm->f64 dst:12 src:12 * diff --git a/libguile/vm.c b/libguile/vm.c index ece3c33e4..3bc59fc15 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -447,6 +447,8 @@ static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE; +static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE; +static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; @@ -584,6 +586,18 @@ vm_error_out_of_range (const char *subr, SCM k) scm_out_of_range (subr, k); } +static void +vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) +{ + scm_out_of_range (subr, scm_from_uint64 (idx)); +} + +static void +vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) +{ + scm_out_of_range (subr, scm_from_int64 (idx)); +} + static void vm_error_no_values (void) { diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index fb7ef7348..c140b4bb3 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -51,8 +51,8 @@ (case word ((C32) 1) ((I32) 1) - ((A32 AU32 AF32) 1) - ((B32 BF32 BU32) 0) + ((A32 AU32 AS32 AF32) 1) + ((B32 BF32 BS32 BU32) 0) ((N32) 1) ((R32) 1) ((L32) 1) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 4123446fd..c378bd1f5 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -802,9 +802,11 @@ are comparable with eqv?. A tmp slot may be used." (intmap-add representations var 'f64)) (($ $primcall (or 'scm->u64 'load-u64 'bv-length 'uadd 'usub 'umul - 'uadd/immediate 'usub/immediate 'umul/immediate)) + 'uadd/immediate 'usub/immediate 'umul/immediate + 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) (intmap-add representations var 'u64)) - (($ $primcall (or 'scm->s64 'load-s64)) + (($ $primcall (or 'scm->s64 'load-s64 + 'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref)) (intmap-add representations var 's64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 9a66917ba..59c3055c3 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -39,6 +39,10 @@ (define (u64? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF)))) + (define (s64? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) + (<= (- #x8000000000000000) val #x7fffFFFFffffFFFF)))) (define (f64? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (number? val) (inexact? val) (real? val)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 72e4dd2aa..a5ea1bf72 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -757,45 +757,6 @@ minimum, and maximum." (max (&min bv) 0) (min (&max bv) *max-size-t*))) (define-syntax-rule (define-bytevector-accessors ref set type size lo hi) - (begin - (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) - (define! result type lo hi)) - (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) - (check-type val type lo hi) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) - (restrict! val type lo hi)))) - -(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) - (define-bytevector-accessors ref set &exact-integer size - (if signed? (- (ash 1 (1- (* size 8)))) 0) - (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) - -(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) -(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) -(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) -(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) - -(define-bytevector-accessors bv-u32-ref bv-u32-set! - &exact-integer 4 #x00000000 #xffffFFFF) -(define-bytevector-accessors bv-s32-ref bv-s32-set! - &exact-integer 4 (- #x80000000) #x7fffFFFF) -(define-bytevector-accessors bv-u64-ref bv-u64-set! - &exact-integer 8 0 &u64-max) -(define-bytevector-accessors bv-s64-ref bv-s64-set! - &exact-integer 8 &s64-min &s64-max) - -(define-syntax-rule (define-bytevector-uaccessors ref set type size lo hi) (begin (define-type-checker (ref bv idx) (and (check-type bv &bytevector 0 *max-size-t*) @@ -814,8 +775,22 @@ minimum, and maximum." (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) (restrict! val type lo hi)))) -(define-bytevector-uaccessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) -(define-bytevector-uaccessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) + +(define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff) +(define-bytevector-accessors bv-s8-ref bv-s8-set! &s64 1 (- #x80) #x7f) + +(define-bytevector-accessors bv-u16-ref bv-u16-set! &u64 2 0 #xffff) +(define-bytevector-accessors bv-s16-ref bv-s16-set! &s64 2 (- #x8000) #x7fff) + +(define-bytevector-accessors bv-u32-ref bv-u32-set! &u64 4 0 #xffffffff) +(define-bytevector-accessors bv-s32-ref bv-s32-set! &s64 4 + (- #x80000000) #x7fffffff) + +(define-bytevector-accessors bv-u64-ref bv-u64-set! &u64 8 0 &u64-max) +(define-bytevector-accessors bv-s64-ref bv-s64-set! &s64 8 &s64-min &s64-max) + +(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index e528ca338..750fd17b1 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -223,7 +223,7 @@ disjoint, an error will be signalled." (($ $primcall 'scm->s64 (val)) (let ((s64 (intmap-ref out val (lambda (_) #f)))) (if (and s64 (number? s64) (exact-integer? s64) - (<= (- #x8000000000000000) u64 #x7fffFFFFffffFFFF)) + (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF)) (intmap-add! out var s64) out))) (_ out))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 2bde7c5d3..c1f976ae0 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -576,13 +576,20 @@ (letk kbox ($kargs ('f64) (f64) ($continue k src ($primcall 'f64->scm (f64))))) kbox)) - ((bv-length) + ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (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)) + ((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref) + (with-cps cps + (letv s64) + (let$ k (adapt-arity k src out)) + (letk kbox ($kargs ('s64) (s64) + ($continue k src ($primcall 's64->scm (s64))))) + kbox)) (else (adapt-arity cps k src out)))) (define (unbox-arg cps arg unbox-op have-arg) @@ -594,7 +601,9 @@ ($continue kunboxed src ($primcall unbox-op (arg)))))) (define (unbox-args cps args have-args) (case instruction - ((bv-f32-ref bv-f64-ref) + ((bv-f32-ref bv-f64-ref + bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref + bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (match args ((bv idx) (unbox-arg @@ -611,6 +620,26 @@ cps val 'scm->f64 (lambda (cps val) (have-args cps (list bv idx val))))))))) + ((bv-s8-set! bv-s16-set! bv-s32-set! bv-s64-set!) + (match args + ((bv idx val) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + cps val 'scm->s64 + (lambda (cps val) + (have-args cps (list bv idx val))))))))) + ((bv-u8-set! bv-u16-set! bv-u32-set! bv-u64-set!) + (match args + ((bv idx val) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + cps val 'scm->u64 + (lambda (cps val) + (have-args cps (list bv idx val))))))))) (else (have-args cps args)))) (convert-args cps args (lambda (cps args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 59b194d16..0e4bbf06c 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -582,8 +582,13 @@ later by the linker." ((AU32 u64) (emit asm (ash u64 -32)) (emit asm (logand u64 (1- (ash 1 32))))) + ((AS32 s64) + (let ((u64 (u64vector-ref (s64vector s64) 0))) + (emit asm (ash u64 -32)) + (emit asm (logand u64 (1- (ash 1 32)))))) ((B32)) ((BU32)) + ((BS32)) ((BF32)) ((N32 label) (record-far-label-reference asm label) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 794caa759..6c21ad609 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -108,7 +108,7 @@ (define (parse-tail-word word type) (with-syntax ((word word)) (case type - ((C32 I32 A32 B32 AU32 BU32 AF32 BF32) + ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32) #'(word)) ((N32 R32 L32 LO32) #'((unpack-s32 word)))