1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-01 09:50:19 +02:00

Add struct-ref' and struct-set' VM opcodes.

* libguile/vm-i-scheme.c (make_struct): Optimize the
  `SCM_VTABLE_FLAG_SIMPLE' case.
  (struct_ref, struct_set): New opcodes.

* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
  `struct-ref' and `struct-set!'.

* module/language/tree-il/primitives.scm
  (*interesting-primitive-names*): Likewise.
  (*effect-free-primitives*): Add `struct-ref'.
This commit is contained in:
Ludovic Courtès 2010-01-23 16:43:50 +01:00
parent 696ac4dfcc
commit a752c0dc27
3 changed files with 79 additions and 3 deletions

View file

@ -645,12 +645,32 @@ VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1)
{ {
unsigned h = FETCH (); unsigned h = FETCH ();
unsigned l = FETCH (); unsigned l = FETCH ();
int n_args = ((h << 8U) + l); scm_t_bits n_args = ((h << 8U) + l);
SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args]; SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
const SCM *inits = sp - n_args + 3; const SCM *inits = sp - n_args + 3;
sp -= n_args - 1; sp -= n_args - 1;
if (SCM_LIKELY (SCM_STRUCTP (vtable)
&& SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
&& SCM_I_INUMP (n_tail)))
{
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);
}
}
SYNC_REGISTER (); SYNC_REGISTER ();
RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail), RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
n_args - 2, (scm_t_bits *) inits)); n_args - 2, (scm_t_bits *) inits));
@ -672,6 +692,60 @@ VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3, -1, 1)
NEXT; NEXT;
} }
VM_DEFINE_FUNCTION (178, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
if (SCM_LIKELY (SCM_STRUCTP (obj)
&& SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
SCM_VTABLE_FLAG_SIMPLE)
&& SCM_I_INUMP (pos)))
{
SCM vtable;
scm_t_bits index, len;
index = SCM_I_INUM (pos);
vtable = SCM_STRUCT_VTABLE (obj);
len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
if (SCM_LIKELY (index < len))
{
scm_t_bits *data = SCM_STRUCT_DATA (obj);
RETURN (SCM_PACK (data[index]));
}
}
RETURN (scm_struct_ref (obj, pos));
}
VM_DEFINE_FUNCTION (179, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
if (SCM_LIKELY (SCM_STRUCTP (obj)
&& SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
SCM_VTABLE_FLAG_SIMPLE)
&& SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
SCM_VTABLE_FLAG_SIMPLE_RW)
&& SCM_I_INUMP (pos)))
{
SCM vtable;
scm_t_bits index, len;
index = SCM_I_INUM (pos);
vtable = SCM_STRUCT_VTABLE (obj);
len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
if (SCM_LIKELY (index < len))
{
scm_t_bits *data = SCM_STRUCT_DATA (obj);
data[index] = SCM_UNPACK (val);
RETURN (val);
}
}
RETURN (scm_struct_set_x (obj, pos, val));
}
/* /*
(defun renumber-ops () (defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"

View file

@ -118,6 +118,8 @@
((variable-set . 2) . variable-set) ((variable-set . 2) . variable-set)
((struct? . 1) . struct?) ((struct? . 1) . struct?)
((struct-vtable . 1) . struct-vtable) ((struct-vtable . 1) . struct-vtable)
((struct-ref . 2) . struct-ref)
((struct-set! . 3) . struct-set)
(make-struct . make-struct) (make-struct . make-struct)
;; hack for javascript ;; hack for javascript

View file

@ -58,7 +58,7 @@
variable-ref variable-set! variable-ref variable-set!
;; args of variable-set are switched; it needs special help ;; args of variable-set are switched; it needs special help
struct? struct-vtable make-struct struct? struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set! bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set! bytevector-s8-ref bytevector-s8-set!
@ -112,7 +112,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 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-ref
struct? struct-vtable make-struct struct? struct-vtable make-struct struct-ref
bytevector-u8-ref bytevector-s8-ref bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref bytevector-s16-ref bytevector-s16-native-ref