[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 33/41: Untag values and indexes for all bytevector instr
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 33/41: Untag values and indexes for all bytevector instructions |
|
Date: |
Wed, 02 Dec 2015 08:06:57 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit a08b3d40f8d1093b96ca4fc8aa440fd71bd0f20e
Author: Andy Wingo <address@hidden>
Date: Sat Nov 21 11:50:15 2015 +0100
Untag values and indexes for all bytevector instructions
* libguile/vm-engine.c (bv-s8-ref, bv-s16-ref, bv-s32-ref, bv-s64-ref):
Unbox index and return unboxed S32 value.
(bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Unbox index and
take unboxed S32 value.
(bv-u8-ref, bv-u16-ref, bv-u32-ref, bv-u64-ref)
(bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Likewise, but
with unsigned values.
(bv-f32-ref, bv-f32-set!, bv-f64-ref, bv-f64-set!): Use memcpy to
access the value so we don't have to think about alignment. GCC will
inline this to a single instruction on architectures that support
unaligned access.
* libguile/vm.c (vm_error_out_of_range_uint64)
(vm_error_out_of_range_int64): New helpers.
* module/language/cps/slot-allocation.scm (compute-var-representations):
All bytevector ref operations produce untagged values.
* module/language/cps/types.scm (define-bytevector-accessors): Update
for bytevector untagged indices and values.
* module/language/cps/utils.scm (compute-constant-values): Fix s64
case.
* module/language/tree-il/compile-cps.scm (convert): Box results of all
bytevector accesses, and unbox incoming indices and values.
---
libguile/instructions.c | 2 +
libguile/vm-engine.c | 241 +++++++-------------------
libguile/vm.c | 14 ++
module/language/bytecode.scm | 4 +-
module/language/cps/slot-allocation.scm | 6 +-
module/language/cps/specialize-primcalls.scm | 4 +
module/language/cps/types.scm | 57 ++-----
module/language/cps/utils.scm | 2 +-
module/language/tree-il/compile-cps.scm | 33 ++++-
module/system/vm/assembler.scm | 5 +
module/system/vm/disassembler.scm | 2 +-
11 files changed, 143 insertions(+), 227 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 49b07d1..29e6098 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 b6d656b..ed39fed 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_ ## slot_type slot_val; \
+ type val; \
scm_t_uint8 dst, idx, src; \
- scm_t_signed_bits i, j = 0; \
- SCM bv, scm_idx, val; \
- scm_t_ ## type *int_ptr; \
- \
+ SCM bv; \
+ scm_t_uint64 c_idx; \
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; \
+ bv = SP_REF (dst); \
+ c_idx = SP_REF_U64 (idx); \
+ slot_val = SP_REF_ ## slot (src); \
\
- 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); \
- } \
+ 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_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_FLOAT_SET(stem, fn_stem, type, size) \
- do { \
+#define BV_SET(stem, type, size, slot) \
+ do { \
+ 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); \
+ 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); \
- } \
+ 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 ece3c33..3bc59fc 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;
@@ -585,6 +587,18 @@ vm_error_out_of_range (const char *subr, SCM 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)
{
vm_error ("Zero values returned to single-valued continuation",
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index fb7ef73..c140b4b 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 4123446..c378bd1 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 9a66917..59c3055 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 72e4dd2..a5ea1bf 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -760,45 +760,6 @@ minimum, and maximum."
(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*)
(check-type idx &u64 0 *max-size-t*)
(< (&max idx) (- (&min bv) size))))
(define-type-inferrer (ref bv idx result)
@@ -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 e528ca3..750fd17 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 2bde7c5..c1f976a 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 59b194d..0e4bbf0 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 794caa7..6c21ad6 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)))
- [Guile-commits] 37/41: Disable warnings on bootstrap build, (continued)
- [Guile-commits] 37/41: Disable warnings on bootstrap build, Andy Wingo, 2015/12/02
- [Guile-commits] 35/41: Add current-thread VM op, Andy Wingo, 2015/12/02
- [Guile-commits] 27/41: Better range inference for indexes of vector-ref, string-ref et al, Andy Wingo, 2015/12/02
- [Guile-commits] 29/41: Remove add1 and sub1, Andy Wingo, 2015/12/02
- [Guile-commits] 30/41: Add tagged and untagged arithmetic ops with immediate operands, Andy Wingo, 2015/12/02
- [Guile-commits] 32/41: Add support for unboxed s64 values, Andy Wingo, 2015/12/02
- [Guile-commits] 39/41: Specialize u64 bit operations, Andy Wingo, 2015/12/02
- [Guile-commits] 31/41: New instructions load-f64, load-u64, Andy Wingo, 2015/12/02
- [Guile-commits] 36/41: Add logsub op., Andy Wingo, 2015/12/02
- [Guile-commits] 40/41: More efficient assembler instructions, Andy Wingo, 2015/12/02
- [Guile-commits] 33/41: Untag values and indexes for all bytevector instructions,
Andy Wingo <=
- [Guile-commits] 41/41: Assembler has a single growable vector, Andy Wingo, 2015/12/02
- [Guile-commits] 38/41: Add untagged bitwise operations, Andy Wingo, 2015/12/02
- [Guile-commits] 34/41: Unbox indexes of vectors, strings, and structs, Andy Wingo, 2015/12/02