diff --git a/libguile/_scm.h b/libguile/_scm.h index a1884cad4..3bb78b466 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -178,7 +178,7 @@ /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 0 -#define SCM_OBJCODE_MINOR_VERSION P +#define SCM_OBJCODE_MINOR_VERSION Q #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/struct.c b/libguile/struct.c index c28a76d48..5b1213cb2 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -391,11 +391,10 @@ struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data) SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words) { - scm_t_bits ret; - ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2), "struct"); - SCM_SET_CELL_WORD_0 (SCM_PACK (ret), (scm_t_bits)vtable_data | scm_tc3_struct); - SCM_SET_CELL_WORD_1 (SCM_PACK (ret), - (scm_t_bits)SCM_CELL_OBJECT_LOC (SCM_PACK (ret), 2)); + SCM ret; + + ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2); + SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); /* vtable_data can be null when making a vtable vtable */ if (vtable_data && vtable_data[scm_vtable_index_instance_finalize]) @@ -403,14 +402,14 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words) /* Register a finalizer for the newly created instance. */ GC_finalization_proc prev_finalizer; GC_PTR prev_finalizer_data; - GC_REGISTER_FINALIZER_NO_ORDER ((void*)ret, + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), struct_finalizer_trampoline, NULL, &prev_finalizer, &prev_finalizer_data); } - return SCM_PACK (ret); + return ret; } diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 3e31691cc..f076d6b8c 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -420,36 +420,34 @@ VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1) { unsigned h = FETCH (); unsigned l = FETCH (); - scm_t_bits n_args = ((h << 8U) + l); - SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args]; - const SCM *inits = sp - n_args + 3; - - sp -= n_args - 1; + scm_t_bits n = ((h << 8U) + l); + SCM vtable = sp[-(n - 1)]; + const SCM *inits = sp - n + 2; + SCM ret; SYNC_REGISTER (); if (SCM_LIKELY (SCM_STRUCTP (vtable) && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && SCM_I_INUMP (n_tail))) + && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1 + == n) + && !SCM_VTABLE_INSTANCE_FINALIZER (vtable))) { - scm_t_bits n_inits, len; - - n_inits = SCM_I_INUM (n_tail) + n_args - 2; - len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - - if (SCM_LIKELY (n_inits == len)) - { - SCM obj; - - obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), n_inits); - memcpy (SCM_STRUCT_DATA (obj), inits, n_inits * sizeof (SCM)); - - RETURN (obj); - } + /* Verily, we are making a simple struct with the right number of + initializers, and no finalizer. */ + ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct, + n + 1); + SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); + memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM)); } + else + ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits); - RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail), - n_args - 2, (scm_t_bits *) inits)); + sp -= n; + NULLSTACK (n); + PUSH (ret); + + NEXT; } VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 4d5e29b64..a07ad669f 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -120,7 +120,7 @@ ((struct-vtable . 1) . struct-vtable) ((struct-ref . 2) . struct-ref) ((struct-set! . 3) . struct-set) - (make-struct . make-struct) + (make-struct/no-tail . make-struct) ;; hack for javascript ((return . 1) . return) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index b6953cabe..c5a80c038 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -212,6 +212,9 @@ exp) ((number? exp) `(make-const src ,exp)) + ((not exp) + ;; failed match + #f) (else (error "bad consequent yall" exp)))) `(hashq-set! *primitive-expand-table* ',sym @@ -317,6 +320,13 @@ (define-primitive-expander variable-set! (var val) (variable-set val var)) +(define-primitive-expander make-struct (vtable tail-size . args) + (if (and (const? tail-size) + (let ((n (const-exp tail-size))) + (and (number? n) (exact? n) (zero? n)))) + (make-struct/no-tail vtable . args) + #f)) + (define-primitive-expander u8vector-ref (vec i) (bytevector-u8-ref vec i)) (define-primitive-expander u8vector-set! (vec i x)