-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
/* {Apply}
*/
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
-#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-/* This code is the same as in gsubr.c, except we use smob_call instead of
- struct_call. */
-
-/* A: req; B: opt; C: rest */
-#define A(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 5 */ scm_op_smob_call, nreq, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, nreq, 0, 0)
-
-#define B(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 8 */ scm_op_smob_call, nopt, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 0)
-
-#define C() \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 5 */ scm_op_smob_call, 1, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, 0, 0, 1)
-
-#define AB(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 11 */ scm_op_smob_call, nreq+nopt, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 0)
-
-#define AC(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 8 */ scm_op_smob_call, nreq+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, nreq, 0, 1)
-
-#define BC(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 8 */ scm_op_smob_call, nopt+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 1)
-
-#define ABC(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob pointer */ \
- /* 11 */ scm_op_smob_call, nreq+nopt+1, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 1)
+static SCM scm_smob_trampolines[16];
-#define META(start, end, nreq, nopt, rest) \
- META_HEADER, \
- /* 0 */ scm_op_make_eol, /* bindings */ \
- /* 1 */ scm_op_make_eol, /* sources */ \
- /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
- /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
- /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \
- /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
- /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \
- /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
- /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
- /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \
- /* 27 */ scm_op_cons, /* make a pair for the properties */ \
- /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
- /* 31 */ scm_op_return /* and return */ \
- /* 32 */
-
-static const struct
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
+ scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)]
+
+static SCM
+apply_0 (SCM smob)
{
- scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
- const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- /* Use the elisp macros from gsubr.c */
- /* C-u 3 M-x generate-bytecodes RET */
- /* 0 arguments */
- A(0),
- /* 1 arguments */
- A(1), B(1), C(),
- /* 2 arguments */
- A(2), AB(1,1), B(2), AC(1), BC(1),
- /* 3 arguments */
- A(3), AB(2,1), AB(1,2), B(3), AC(2), ABC(1,1), BC(2)
- }
-};
-
-#undef A
-#undef B
-#undef C
-#undef AB
-#undef AC
-#undef BC
-#undef ABC
-#undef OBJCODE_HEADER
-#undef META_HEADER
-#undef META
-
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob);
+}
+
+static SCM
+apply_1 (SCM smob, SCM a)
{
- scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[16 * 2]; /* 4*4 double cells */
-} objcode_cells = {
- 0,
- /* C-u 3 M-x generate-objcode-cells RET */
- {
- /* 0 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 1 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 2 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 3 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-static const SCM scm_smob_objcode_trampolines[16] = {
- /* C-u 3 M-x generate-objcodes RET */
- /* 0 arguments */
- SCM_PACK (objcode_cells.cells+0),
-
- /* 1 arguments */
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
-
- /* 2 arguments */
- SCM_PACK (objcode_cells.cells+8),
- SCM_PACK (objcode_cells.cells+10),
- SCM_PACK (objcode_cells.cells+12),
- SCM_PACK (objcode_cells.cells+14),
- SCM_PACK (objcode_cells.cells+16),
-
- /* 3 arguments */
- SCM_PACK (objcode_cells.cells+18),
- SCM_PACK (objcode_cells.cells+20),
- SCM_PACK (objcode_cells.cells+22),
- SCM_PACK (objcode_cells.cells+24),
- SCM_PACK (objcode_cells.cells+26),
- SCM_PACK (objcode_cells.cells+28),
- SCM_PACK (objcode_cells.cells+30)
-};
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a);
+}
-/* (nargs * nargs) + nopt + rest * (nargs + 1) */
-#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
- scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
- + nopt + rest * (nreq + nopt + rest + 1)]
+static SCM
+apply_2 (SCM smob, SCM a, SCM b)
+{
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a, b);
+}
+
+static SCM
+apply_3 (SCM smob, SCM a, SCM b, SCM c)
+{
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a, b, c);
+}
static SCM
-scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
- unsigned int rest)
+scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
+ unsigned int rest)
{
+ SCM trampoline;
+
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
- return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
+ trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);
+
+ if (SCM_LIKELY (SCM_UNPACK (trampoline)))
+ return trampoline;
+
+ switch (nreq + nopt + rest)
+ {
+ /* The + 1 is for the smob itself. */
+ case 0:
+ trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
+ apply_0);
+ break;
+ case 1:
+ trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
+ apply_1);
+ break;
+ case 2:
+ trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
+ apply_2);
+ break;
+ case 3:
+ trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
+ apply_3);
+ break;
+ default:
+ abort ();
+ }
+
+ SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;
+
+ return trampoline;
}
\f
scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
unsigned int req, unsigned int opt, unsigned int rst)
{
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
- = scm_smob_objcode_trampoline (req, opt, rst);
+ SCM trampoline = scm_smob_trampoline (req, opt, rst);
+
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
+ /* In 2.2 this field is renamed to "apply_trampoline". */
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline;
if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}
-static SCM tramp_weak_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-SCM
-scm_i_smob_apply_trampoline (SCM smob)
-{
- SCM tramp;
-
- scm_i_pthread_mutex_lock (&tramp_lock);
- tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&tramp_lock);
-
- if (scm_is_true (tramp))
- return tramp;
- else
- {
- const char *name;
- SCM objtable;
-
- name = SCM_SMOBNAME (SCM_SMOBNUM (smob));
- if (!name)
- name = "smob-apply";
- objtable = scm_c_make_vector (2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
- SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
- tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
- objtable, SCM_BOOL_F);
-
- /* Race conditions (between the ref and this set!) cannot cause
- any harm here. */
- scm_i_pthread_mutex_lock (&tramp_lock);
- scm_hashq_set_x (tramp_weak_map, smob, tramp);
- scm_i_pthread_mutex_unlock (&tramp_lock);
- return tramp;
- }
-}
-
SCM
scm_make_smob (scm_t_bits tc)
{
/* The GC kind used for SMOB types that provide a custom mark procedure. */
static int smob_gc_kind;
+/* Mark stack pointer and limit, used by `scm_gc_mark'. */
+static scm_i_pthread_key_t current_mark_stack_pointer;
+static scm_i_pthread_key_t current_mark_stack_limit;
+
/* The generic SMOB mark procedure that gets called for SMOBs allocated
with smob_gc_kind. */
{
SCM obj;
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
- SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
+ scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
/* Invoke the SMOB's mark procedure, which will in turn invoke
- `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
+ `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
obj = scm_smobs[smobnum].mark (cell);
- mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
if (SCM_NIMP (obj))
/* Mark the returned object. */
mark_stack_ptr,
mark_stack_limit, NULL);
- SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
+ scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
}
return mark_stack_ptr;
}
-/* Mark object O. We assume that this function is only called during the
- mark phase, i.e., from within `smob_mark ()' or one of its
- descendents. */
+/* Mark object O. We assume that this function is only called during the mark
+ phase, i.e., from within `smob_mark' or one of its descendants. */
void
scm_gc_mark (SCM o)
{
-#define CURRENT_MARK_PTR \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
-#define CURRENT_MARK_LIMIT \
- ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
-
if (SCM_NIMP (o))
{
- /* At this point, the `current_mark_*' fields of the current thread
- must be defined (they are set in `smob_mark ()'). */
- register struct GC_ms_entry *mark_stack_ptr;
+ void *mark_stack_ptr, *mark_stack_limit;
+
+ mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
+ mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
- if (!CURRENT_MARK_PTR)
+ if (mark_stack_ptr == NULL)
/* The function was not called from a mark procedure. */
abort ();
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
- CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
+ mark_stack_ptr, mark_stack_limit,
NULL);
- SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
+ scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
}
-#undef CURRENT_MARK_PTR
-#undef CURRENT_MARK_LIMIT
}
\f
/* Finalize SMOB by calling its SMOB type's free function, if any. */
static void
-finalize_smob (GC_PTR ptr, GC_PTR data)
+finalize_smob (void *ptr, void *data)
{
SCM smob;
size_t (* free_smob) (SCM);
SCM_NEWSMOB and are no longer used. They are still here to preserve
ABI stability in the 2.0 series. */
void
-scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
+scm_i_finalize_smob (void *ptr, void *data)
{
finalize_smob (ptr, data);
}
{
long i;
+ scm_i_pthread_key_create (¤t_mark_stack_pointer, NULL);
+ scm_i_pthread_key_create (¤t_mark_stack_limit, NULL);
+
smob_gc_kind = GC_new_kind (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
0,
scm_smobs[i].apply = 0;
scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
}
-
- tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}
/*
HCoop / bpt / guile.git / blobdiff