From d6f1ce3d1627e27c2262cb8da15828d515050fd6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 26 Jun 2009 00:15:37 +0200 Subject: [PATCH] vector-ref and vector-set! now have opcodes * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Resolve vector-ref and vector-set!. * module/language/tree-il/compile-glil.scm (*primcall-ops*): And compile vector-ref and vector-set! to their opcodes. * libguile/vm-i-scheme.c (vector-ref, vector-set): New opcodes, placed before the bytevector ops. The renumbering shouldn't affect anyone, given that the bytevector ops were not yet used. Fix a few bugs in the bytevector ops. --- libguile/vm-i-scheme.c | 123 ++++++++++++++--------- module/language/tree-il/compile-glil.scm | 5 +- module/language/tree-il/primitives.scm | 4 +- 3 files changed, 83 insertions(+), 49 deletions(-) diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index e074d36a0..0039d92cd 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -279,6 +279,34 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) NEXT; } +VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2) +{ + long i; + ARGS2 (vect, idx); + if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) + && SCM_I_INUMP (idx) + && ((i = SCM_I_INUM (idx)) >= 0) + && i < SCM_I_VECTOR_LENGTH (vect))) + RETURN (SCM_I_VECTOR_ELTS (vect)[i]); + else + RETURN (scm_vector_ref (vect, idx)); +} + +VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0) +{ + long i; + SCM vect, idx, val; + POP (val); POP (idx); POP (vect); + if (SCM_LIKELY (SCM_I_IS_VECTOR (vect) + && SCM_I_INUMP (idx) + && ((i = SCM_I_INUM (idx)) >= 0) + && i < SCM_I_VECTOR_LENGTH (vect))) + SCM_I_VECTOR_WELTS (vect)[i] = val; + else + scm_vector_set_x (vect, idx, val); + NEXT; +} + #define VM_VALIDATE_BYTEVECTOR(x) \ if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \ { finish_args = x; \ @@ -297,21 +325,21 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0) } \ } -VM_DEFINE_FUNCTION (109, bv_u16_ref, "bv-u16-ref", 3) +VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (110, bv_s16_ref, "bv-s16-ref", 3) +VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (111, bv_u32_ref, "bv-u32-ref", 3) +VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (112, bv_s32_ref, "bv-s32-ref", 3) +VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (113, bv_u64_ref, "bv-u64-ref", 3) +VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (114, bv_s64_ref, "bv-s64-ref", 3) +VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (115, bv_f32_ref, "bv-f32-ref", 3) +VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (116, bv_f64_ref, "bv-f64-ref", 3) +VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS @@ -322,7 +350,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \ @@ -337,7 +365,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \ @@ -356,7 +384,7 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) ARGS2 (bv, idx); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \ @@ -364,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double) RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \ } -VM_DEFINE_FUNCTION (117, bv_u8_ref, "bv-u8-ref", 2) +VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (118, bv_s8_ref, "bv-s8-ref", 2) +VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (119, bv_u16_native_ref, "bv-u16-native-ref", 2) +VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (120, bv_s16_native_ref, "bv-s16-native-ref", 2) +VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (121, bv_u32_native_ref, "bv-u32-native-ref", 2) +VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_REF (u32, uint32, 4) -VM_DEFINE_FUNCTION (122, bv_s32_native_ref, "bv-s32-native-ref", 2) +VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2) BV_INT_REF (s32, int32, 4) -VM_DEFINE_FUNCTION (123, bv_u64_native_ref, "bv-u64-native-ref", 2) +VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (124, bv_s64_native_ref, "bv-s64-native-ref", 2) +VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (125, bv_f32_native_ref, "bv-f32-native-ref", 2) +VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (126, bv_f64_native_ref, "bv-f64-native-ref", 2) +VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF @@ -399,26 +427,27 @@ BV_FLOAT_REF (f64, ieee_double, double, 8) if (scm_is_eq (endianness, scm_i_native_endianness)) \ goto VM_LABEL (bv_##stem##_native_set); \ { \ - ARGS3 (bv, idx, val); \ - RETURN (scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness)); \ + SCM bv, idx, val; POP (val); POP (idx); POP (bv); \ + scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \ + NEXT; \ } \ } -VM_DEFINE_FUNCTION (127, bv_u16_set, "bv-u16-set", 4) +VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (128, bv_s16_set, "bv-s16-set", 4) +VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (129, bv_u32_set, "bv-u32-set", 4) +VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (130, bv_s32_set, "bv-s32-set", 4) +VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (131, bv_u64_set, "bv-u64-set", 4) +VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (132, bv_s64_set, "bv-s64-set", 4) +VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (133, bv_f32_set, "bv-f32-set", 4) +VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (134, bv_f64_set, "bv-f64-set", 4) +VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS @@ -429,11 +458,11 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0) \ && (SCM_I_INUMP (val)) \ - && ((j = SCM_INUM (val)) >= min) \ + && ((j = SCM_I_INUM (val)) >= min) \ && (j <= max))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \ else \ @@ -447,7 +476,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \ @@ -462,7 +491,7 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) ARGS3 (bv, idx, val); \ VM_VALIDATE_BYTEVECTOR (bv); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && ((i = SCM_INUM (idx)) >= 0) \ + && ((i = SCM_I_INUM (idx)) >= 0) \ && (i < SCM_BYTEVECTOR_LENGTH (bv)) \ && (i % size == 0))) \ *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \ @@ -470,26 +499,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double) scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \ } -VM_DEFINE_FUNCTION (135, bv_u8_set, "bv-u8-set", 3) +VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_FUNCTION (136, bv_s8_set, "bv-s8-set", 3) +VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_FUNCTION (137, bv_u16_native_set, "bv-u16-native-set", 3) -BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 3) -VM_DEFINE_FUNCTION (138, bv_s16_native_set, "bv-s16-native-set", 3) -BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 3) -VM_DEFINE_FUNCTION (139, bv_u32_native_set, "bv-u32-native-set", 3) +VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) +BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) +VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) +BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) +VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) /* FIXME: u32 is always a fixnum on 64-bit builds */ BV_INT_SET (u32, uint32, 4) -VM_DEFINE_FUNCTION (140, bv_s32_native_set, "bv-s32-native-set", 3) +VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) BV_INT_SET (s32, int32, 4) -VM_DEFINE_FUNCTION (141, bv_u64_native_set, "bv-u64-native-set", 3) +VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) -VM_DEFINE_FUNCTION (142, bv_s64_native_set, "bv-s64-native-set", 3) +VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) -VM_DEFINE_FUNCTION (143, bv_f32_native_set, "bv-f32-native-set", 3) +VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (144, bv_f64_native_set, "bv-f64-native-set", 3) +VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a75843d2f..fcfdf1c09 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -81,7 +81,10 @@ (list . list) (vector . vector) ((@slot-ref . 2) . slot-ref) - ((@slot-set! . 3) . slot-set))) + ((@slot-set! . 3) . slot-set) + ((vector-ref . 2) . vector-ref) + ((vector-set! . 3) . vector-set) + )) (define (make-label) (gensym ":L")) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7daae0c62..cde3bbef3 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -47,7 +47,9 @@ caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + vector-ref vector-set!)) (define (add-interesting-primitive! name) (hashq-set! *interesting-primitive-vars*