mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-29 08:20:20 +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:
parent
696ac4dfcc
commit
a752c0dc27
3 changed files with 79 additions and 3 deletions
|
@ -645,12 +645,32 @@ VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1)
|
|||
{
|
||||
unsigned h = 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];
|
||||
const SCM *inits = sp - n_args + 3;
|
||||
|
||||
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 ();
|
||||
RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
|
||||
n_args - 2, (scm_t_bits *) inits));
|
||||
|
@ -672,6 +692,60 @@ VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3, -1, 1)
|
|||
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 ()
|
||||
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
|
||||
|
|
|
@ -118,6 +118,8 @@
|
|||
((variable-set . 2) . variable-set)
|
||||
((struct? . 1) . struct?)
|
||||
((struct-vtable . 1) . struct-vtable)
|
||||
((struct-ref . 2) . struct-ref)
|
||||
((struct-set! . 3) . struct-set)
|
||||
(make-struct . make-struct)
|
||||
|
||||
;; hack for javascript
|
||||
|
|
|
@ -58,7 +58,7 @@
|
|||
variable-ref variable-set!
|
||||
;; 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-s8-ref bytevector-s8-set!
|
||||
|
@ -112,7 +112,7 @@
|
|||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
vector-ref
|
||||
struct? struct-vtable make-struct
|
||||
struct? struct-vtable make-struct struct-ref
|
||||
bytevector-u8-ref bytevector-s8-ref
|
||||
bytevector-u16-ref bytevector-u16-native-ref
|
||||
bytevector-s16-ref bytevector-s16-native-ref
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue