mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
8bf77f7192
commit
a08b3d40f8
11 changed files with 151 additions and 235 deletions
|
|
@ -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. */ \
|
||||
|
|
|
|||
|
|
@ -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); \
|
||||
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); \
|
||||
} \
|
||||
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); \
|
||||
} \
|
||||
} 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) \
|
||||
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) \
|
||||
#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 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); \
|
||||
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
|
||||
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \
|
||||
slot_val = SP_REF_ ## slot (src); \
|
||||
\
|
||||
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); \
|
||||
} \
|
||||
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); \
|
||||
\
|
||||
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
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue