mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Untag values and indexes for all bytevector instructions

Browse source 
* 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 2015-11-21 11:50:15 +01:00
parent 8bf77f7192
commit a08b3d40f8
11 changed files with 151 additions and 235 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/instructions.c
View file

@ -54,6 +54,8 @@ SCM_SYMBOL (sym_bang, "!");
M(BF32) /* Immediate double, low bits. */ \ M(BF32) /* Immediate double, low bits. */ \
M(AU32) /* Immediate uint64, high bits. */ \ M(AU32) /* Immediate uint64, high bits. */ \
M(BU32) /* Immediate uint64, low bits. */ \ M(BU32) /* Immediate uint64, low bits. */ \
M(AS32) /* Immediate int64, high bits. */ \
M(BS32) /* Immediate int64, low bits. */ \
M(N32) /* Non-immediate. */ \ M(N32) /* Non-immediate. */ \
M(R32) /* Scheme value (indirected). */ \ M(R32) /* Scheme value (indirected). */ \
M(L32) /* Label. */ \ M(L32) /* Label. */ \

257
libguile/vm-engine.c
View file

@ -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 * Fetch the item at byte offset IDX in the bytevector SRC, and store
* it in DST. All accesses use native endianness. * 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 { \ do { \
scm_t_signed_bits i; \ type result; \
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; \
scm_t_uint8 dst, src, idx; \ scm_t_uint8 dst, src, idx; \
SCM bv; \ SCM bv; \
scm_t_uint64 c_idx; \ 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); \ c_idx = SP_REF_U64 (idx); \
\ \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \
\ \
if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \
&& (c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size) \ || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \
&& (ALIGNED_P (float_ptr, type)))) \ vm_error_out_of_range_uint64 ("bv-" #stem "-ref", c_idx); \
{ \ \
SP_SET_F64 (dst, *float_ptr); \ memcpy (&result, SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, size); \
NEXT (1); \ 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) } while (0)
VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) 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) 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) 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) 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) VM_DEFINE_OP (120, bv_u32_ref, "bv-u32-ref", OP1 (X8_S8_S8_S8) | OP_DST)
#if SIZEOF_VOID_P > 4 BV_REF (u32, scm_t_uint32, 4, U64);
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
#else
BV_INT_REF (u32, uint32, 4);
#endif
VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST) VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST)
#if SIZEOF_VOID_P > 4 BV_REF (s32, scm_t_int32, 4, S64);
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
#else
BV_INT_REF (s32, int32, 4);
#endif
VM_DEFINE_OP (122, bv_u64_ref, "bv-u64-ref", OP1 (X8_S8_S8_S8) | OP_DST) 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) 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) 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) 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-u8-set! dst:8 idx:8 src:8
* bv-s8-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 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
* values are written using native endianness. * 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 { \ do { \
scm_t_uint8 dst, idx, src; \ scm_t_ ## slot_type slot_val; \
scm_t_signed_bits i, j = 0; \ type val; \
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_uint8 dst, idx, src; \ scm_t_uint8 dst, idx, src; \
SCM bv; \ SCM bv; \
scm_t_uint64 c_idx; \ scm_t_uint64 c_idx; \
double val; \
type *float_ptr; \
\
UNPACK_8_8_8 (op, dst, idx, src); \ UNPACK_8_8_8 (op, dst, idx, src); \
bv = SP_REF (dst); \ bv = SP_REF (dst); \
c_idx = SP_REF_U64 (idx); \ c_idx = SP_REF_U64 (idx); \
val = SP_REF_F64 (src); \ slot_val = SP_REF_ ## slot (src); \
\
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ 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) \ if (SCM_UNLIKELY (slot_val < min) || SCM_UNLIKELY (slot_val > max)) \
&& c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size \ vm_error_out_of_range_ ## slot_type ("bv-" #stem "-set!", \
&& ALIGNED_P (float_ptr, type))) \ slot_val); \
*float_ptr = val; \ \
else \ val = slot_val; \
{ \ memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \
SCM boxed_idx, boxed_val; \ NEXT (1); \
boxed_idx = scm_from_uint64 (c_idx); \ } while (0)
boxed_val = scm_from_double (val); \
SYNC_IP (); \ #define BV_SET(stem, type, size, slot) \
scm_bytevector_ ## fn_stem ## _native_set_x (bv, boxed_idx, \ do { \
boxed_val); \ 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); \ NEXT (1); \
} while (0) } while (0)
VM_DEFINE_OP (126, bv_u8_set, "bv-u8-set!", OP1 (X8_S8_S8_S8)) 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)) 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)) 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)) 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)) VM_DEFINE_OP (130, bv_u32_set, "bv-u32-set!", OP1 (X8_S8_S8_S8))
#if SIZEOF_VOID_P > 4 BV_BOUNDED_SET (u32, scm_t_uint32,
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); 0, SCM_T_UINT32_MAX, 4, uint64, U64);
#else
BV_INT_SET (u32, uint32, 4);
#endif
VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8)) VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8))
#if SIZEOF_VOID_P > 4 BV_BOUNDED_SET (s32, scm_t_int32,
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4, int64, S64);
#else
BV_INT_SET (s32, int32, 4);
#endif
VM_DEFINE_OP (132, bv_u64_set, "bv-u64-set!", OP1 (X8_S8_S8_S8)) 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)) 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)) 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)) 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 /* scm->f64 dst:12 src:12
* *

14
libguile/vm.c
View file

@ -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_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_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 (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_no_values (void) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_enough_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; 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); 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 static void
vm_error_no_values (void) vm_error_no_values (void)
{ {

4
module/language/bytecode.scm
View file

@ -51,8 +51,8 @@
(case word (case word
((C32) 1) ((C32) 1)
((I32) 1) ((I32) 1)
((A32 AU32 AF32) 1) ((A32 AU32 AS32 AF32) 1)
((B32 BF32 BU32) 0) ((B32 BF32 BS32 BU32) 0)
((N32) 1) ((N32) 1)
((R32) 1) ((R32) 1)
((L32) 1) ((L32) 1)

6
module/language/cps/slot-allocation.scm
View file

@ -802,9 +802,11 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add representations var 'f64)) (intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'load-u64 'bv-length (($ $primcall (or 'scm->u64 'load-u64 'bv-length
'uadd 'usub 'umul '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)) (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 's64))
(_ (_
(intmap-add representations var 'scm)))) (intmap-add representations var 'scm))))

4
module/language/cps/specialize-primcalls.scm
View file

@ -39,6 +39,10 @@
(define (u64? var) (define (u64? var)
(let ((val (intmap-ref constants var (lambda (_) #f)))) (let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF)))) (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) (define (f64? var)
(let ((val (intmap-ref constants var (lambda (_) #f)))) (let ((val (intmap-ref constants var (lambda (_) #f))))
(and (number? val) (inexact? val) (real? val)))) (and (number? val) (inexact? val) (real? val))))

57
module/language/cps/types.scm
View file

@ -757,45 +757,6 @@ minimum, and maximum."
(max (&min bv) 0) (min (&max bv) *max-size-t*))) (max (&min bv) 0) (min (&max bv) *max-size-t*)))
(define-syntax-rule (define-bytevector-accessors ref set type size lo hi) (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 (begin
(define-type-checker (ref bv idx) (define-type-checker (ref bv idx)
(and (check-type bv &bytevector 0 *max-size-t*) (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! bv &bytevector (+ (&min idx) size) *max-size-t*)
(restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size))
(restrict! val type lo hi)))) (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)

2
module/language/cps/utils.scm
View file

@ -223,7 +223,7 @@ disjoint, an error will be signalled."
(($ $primcall 'scm->s64 (val)) (($ $primcall 'scm->s64 (val))
(let ((s64 (intmap-ref out val (lambda (_) #f)))) (let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64) (if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) u64 #x7fffFFFFffffFFFF)) (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
(intmap-add! out var s64) (intmap-add! out var s64)
out))) out)))
(_ out))) (_ out)))

33
module/language/tree-il/compile-cps.scm
View file

@ -576,13 +576,20 @@
(letk kbox ($kargs ('f64) (f64) (letk kbox ($kargs ('f64) (f64)
($continue k src ($primcall 'f64->scm (f64))))) ($continue k src ($primcall 'f64->scm (f64)))))
kbox)) kbox))
((bv-length) ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
(with-cps cps (with-cps cps
(letv u64) (letv u64)
(let$ k (adapt-arity k src out)) (let$ k (adapt-arity k src out))
(letk kbox ($kargs ('u64) (u64) (letk kbox ($kargs ('u64) (u64)
($continue k src ($primcall 'u64->scm (u64))))) ($continue k src ($primcall 'u64->scm (u64)))))
kbox)) 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 (else
(adapt-arity cps k src out)))) (adapt-arity cps k src out))))
(define (unbox-arg cps arg unbox-op have-arg) (define (unbox-arg cps arg unbox-op have-arg)
@ -594,7 +601,9 @@
($continue kunboxed src ($primcall unbox-op (arg)))))) ($continue kunboxed src ($primcall unbox-op (arg))))))
(define (unbox-args cps args have-args) (define (unbox-args cps args have-args)
(case instruction (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 (match args
((bv idx) ((bv idx)
(unbox-arg (unbox-arg
@ -611,6 +620,26 @@
cps val 'scm->f64 cps val 'scm->f64
(lambda (cps val) (lambda (cps val)
(have-args cps (list bv idx 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)))) (else (have-args cps args))))
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)

5
module/system/vm/assembler.scm
View file

@ -582,8 +582,13 @@ later by the linker."
((AU32 u64) ((AU32 u64)
(emit asm (ash u64 -32)) (emit asm (ash u64 -32))
(emit asm (logand u64 (1- (ash 1 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)) ((B32))
((BU32)) ((BU32))
((BS32))
((BF32)) ((BF32))
((N32 label) ((N32 label)
(record-far-label-reference asm label) (record-far-label-reference asm label)

2
module/system/vm/disassembler.scm
View file

@ -108,7 +108,7 @@
(define (parse-tail-word word type) (define (parse-tail-word word type)
(with-syntax ((word word)) (with-syntax ((word word))
(case type (case type
((C32 I32 A32 B32 AU32 BU32 AF32 BF32) ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
#'(word)) #'(word))
((N32 R32 L32 LO32) ((N32 R32 L32 LO32)
#'((unpack-s32 word))) #'((unpack-s32 word)))