1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
2 * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
32 #include "libguile/async.h"
33 #include "libguile/goops.h"
34 #include "libguile/instructions.h"
35 #include "libguile/programs.h"
37 #include "libguile/smob.h"
39 #include "libguile/bdw-gc.h"
40 #include <gc/gc_mark.h>
45 /* scm_smobs scm_numsmob
46 * implement a fixed sized array of smob records.
47 * Indexes into this table are used when generating type
48 * tags for smobjects (if you know a tag you can get an index and conversely).
51 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
54 scm_smob_descriptor scm_smobs
[MAX_SMOB_COUNT
];
57 scm_assert_smob_type (scm_t_bits tag
, SCM val
)
59 if (!SCM_SMOB_PREDICATE (tag
, val
))
60 scm_wrong_type_arg_msg (NULL
, 0, val
, scm_smobs
[SCM_TC2SMOBNUM(tag
)].name
);
66 /* This function is vestigial. It used to be the mark function's
67 responsibility to set the mark bit on the smob or port, but now the
68 generic marking routine in gc.c takes care of that, and a zero
69 pointer for a mark function means "don't bother". So you never
72 However, we leave it here because it's harmless to call it, and
73 people out there have smob code that uses it, and there's no reason
74 to make their links fail. */
77 scm_mark0 (SCM ptr SCM_UNUSED
)
83 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
84 be used for real pairs. */
87 return SCM_CELL_OBJECT_1 (ptr
);
95 scm_free0 (SCM ptr SCM_UNUSED
)
105 scm_smob_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
107 long n
= SCM_SMOBNUM (exp
);
108 scm_puts_unlocked ("#<", port
);
109 scm_puts_unlocked (SCM_SMOBNAME (n
) ? SCM_SMOBNAME (n
) : "smob", port
);
110 scm_putc_unlocked (' ', port
);
111 if (scm_smobs
[n
].size
)
112 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
114 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
115 scm_putc_unlocked ('>', port
);
123 static SCM scm_smob_trampolines
[16];
125 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
126 #define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
127 scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
128 + nopt + rest * (nreq + nopt + rest + 1)]
133 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
138 apply_1 (SCM smob
, SCM a
)
140 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
141 return subr (smob
, a
);
145 apply_2 (SCM smob
, SCM a
, SCM b
)
147 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
148 return subr (smob
, a
, b
);
152 apply_3 (SCM smob
, SCM a
, SCM b
, SCM c
)
154 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
155 return subr (smob
, a
, b
, c
);
159 scm_smob_trampoline (unsigned int nreq
, unsigned int nopt
,
164 if (SCM_UNLIKELY (rest
> 1 || nreq
+ nopt
+ rest
> 3))
165 scm_out_of_range ("make-smob", scm_from_uint (nreq
+ nopt
+ rest
));
167 trampoline
= SCM_SMOB_TRAMPOLINE (nreq
, nopt
, rest
);
169 if (SCM_LIKELY (SCM_UNPACK (trampoline
)))
172 switch (nreq
+ nopt
+ rest
)
174 /* The + 1 is for the smob itself. */
176 trampoline
= scm_c_make_gsubr ("apply-smob/0", nreq
+ 1, nopt
, rest
,
180 trampoline
= scm_c_make_gsubr ("apply-smob/1", nreq
+ 1, nopt
, rest
,
184 trampoline
= scm_c_make_gsubr ("apply-smob/2", nreq
+ 1, nopt
, rest
,
188 trampoline
= scm_c_make_gsubr ("apply-smob/3", nreq
+ 1, nopt
, rest
,
195 SCM_SMOB_TRAMPOLINE (nreq
, nopt
, rest
) = trampoline
;
203 scm_make_smob_type (char const *name
, size_t size
)
204 #define FUNC_NAME "scm_make_smob_type"
208 scm_i_pthread_mutex_lock (&scm_i_misc_mutex
);
209 new_smob
= scm_numsmob
;
210 if (scm_numsmob
!= MAX_SMOB_COUNT
)
212 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex
);
214 if (new_smob
== MAX_SMOB_COUNT
)
215 scm_misc_error (FUNC_NAME
, "maximum number of smobs exceeded", SCM_EOL
);
217 scm_smobs
[new_smob
].name
= name
;
218 scm_smobs
[new_smob
].size
= size
;
220 /* Make a class object if Goops is present. */
221 if (SCM_UNPACK (scm_smob_class
[0]) != 0)
222 scm_smob_class
[new_smob
] = scm_make_extended_class (name
, 0);
224 return scm_tc7_smob
+ new_smob
* 256;
230 scm_set_smob_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
232 scm_smobs
[SCM_TC2SMOBNUM (tc
)].mark
= mark
;
236 scm_set_smob_free (scm_t_bits tc
, size_t (*free
) (SCM
))
238 scm_smobs
[SCM_TC2SMOBNUM (tc
)].free
= free
;
242 scm_set_smob_print (scm_t_bits tc
, int (*print
) (SCM
, SCM
, scm_print_state
*))
244 scm_smobs
[SCM_TC2SMOBNUM (tc
)].print
= print
;
248 scm_set_smob_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
250 scm_smobs
[SCM_TC2SMOBNUM (tc
)].equalp
= equalp
;
254 scm_set_smob_apply (scm_t_bits tc
, SCM (*apply
) (),
255 unsigned int req
, unsigned int opt
, unsigned int rst
)
257 SCM trampoline
= scm_smob_trampoline (req
, opt
, rst
);
259 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply
= apply
;
260 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_trampoline
= trampoline
;
262 if (SCM_UNPACK (scm_smob_class
[0]) != 0)
263 scm_i_inherit_applicable (scm_smob_class
[SCM_TC2SMOBNUM (tc
)]);
267 scm_make_smob (scm_t_bits tc
)
269 scm_t_bits n
= SCM_TC2SMOBNUM (tc
);
270 size_t size
= scm_smobs
[n
].size
;
271 scm_t_bits data
= (size
> 0
272 ? (scm_t_bits
) scm_gc_malloc (size
, SCM_SMOBNAME (n
))
275 SCM_RETURN_NEWSMOB (tc
, data
);
280 /* Marking SMOBs using user-supplied mark procedures. */
283 /* The GC kind used for SMOB types that provide a custom mark procedure. */
284 static int smob_gc_kind
;
286 /* Mark stack pointer and limit, used by `scm_gc_mark'. */
287 static scm_i_pthread_key_t current_mark_stack_pointer
;
288 static scm_i_pthread_key_t current_mark_stack_limit
;
291 /* The generic SMOB mark procedure that gets called for SMOBs allocated
292 with smob_gc_kind. */
293 static struct GC_ms_entry
*
294 smob_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
295 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
298 register scm_t_bits tc
, smobnum
;
300 cell
= SCM_PACK_POINTER (addr
);
302 if (SCM_TYP7 (cell
) != scm_tc7_smob
)
303 /* It is likely that the GC passed us a pointer to a free-list element
304 which we must ignore (see warning in `gc/gc_mark.h'). */
305 return mark_stack_ptr
;
307 tc
= SCM_CELL_WORD_0 (cell
);
308 smobnum
= SCM_TC2SMOBNUM (tc
);
310 if (smobnum
>= scm_numsmob
)
311 /* The first word looks corrupt. */
314 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell
)),
316 mark_stack_limit
, NULL
);
317 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell
)),
319 mark_stack_limit
, NULL
);
320 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell
)),
322 mark_stack_limit
, NULL
);
324 if (scm_smobs
[smobnum
].mark
)
328 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
329 scm_i_pthread_setspecific (current_mark_stack_limit
, mark_stack_limit
);
331 /* Invoke the SMOB's mark procedure, which will in turn invoke
332 `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
333 obj
= scm_smobs
[smobnum
].mark (cell
);
335 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
337 if (SCM_HEAP_OBJECT_P (obj
))
338 /* Mark the returned object. */
339 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (obj
),
341 mark_stack_limit
, NULL
);
343 scm_i_pthread_setspecific (current_mark_stack_pointer
, NULL
);
344 scm_i_pthread_setspecific (current_mark_stack_limit
, NULL
);
347 return mark_stack_ptr
;
351 /* Mark object O. We assume that this function is only called during the mark
352 phase, i.e., from within `smob_mark' or one of its descendants. */
356 if (SCM_HEAP_OBJECT_P (o
))
358 void *mark_stack_ptr
, *mark_stack_limit
;
360 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
361 mark_stack_limit
= scm_i_pthread_getspecific (current_mark_stack_limit
);
363 if (mark_stack_ptr
== NULL
)
364 /* The function was not called from a mark procedure. */
367 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (o
),
368 mark_stack_ptr
, mark_stack_limit
,
370 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
375 /* Finalize SMOB by calling its SMOB type's free function, if any. */
377 finalize_smob (void *ptr
, void *data
)
380 size_t (* free_smob
) (SCM
);
382 smob
= SCM_PACK_POINTER (ptr
);
384 printf ("finalizing SMOB %p (smobnum: %u)\n",
385 ptr
, SCM_SMOBNUM (smob
));
388 free_smob
= scm_smobs
[SCM_SMOBNUM (smob
)].free
;
393 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
394 provide a custom mark procedure and it will be honored. */
396 scm_i_new_smob (scm_t_bits tc
, scm_t_bits data
)
398 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
401 /* Use the smob_gc_kind if needed to allow the mark procedure to
402 run. Since the marker only deals with double cells, that case
403 allocates a double cell. We leave words 2 and 3 to there initial
404 values, which is 0. */
405 if (scm_smobs
[smobnum
].mark
)
406 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
408 ret
= SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell
)));
410 SCM_SET_CELL_WORD_1 (ret
, data
);
411 SCM_SET_CELL_WORD_0 (ret
, tc
);
413 if (scm_smobs
[smobnum
].free
)
414 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
419 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
420 provide a custom mark procedure and it will be honored. */
422 scm_i_new_double_smob (scm_t_bits tc
, scm_t_bits data1
,
423 scm_t_bits data2
, scm_t_bits data3
)
425 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
428 /* Use the smob_gc_kind if needed to allow the mark procedure to
430 if (scm_smobs
[smobnum
].mark
)
431 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
433 ret
= SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell
)));
435 SCM_SET_CELL_WORD_3 (ret
, data3
);
436 SCM_SET_CELL_WORD_2 (ret
, data2
);
437 SCM_SET_CELL_WORD_1 (ret
, data1
);
438 SCM_SET_CELL_WORD_0 (ret
, tc
);
440 if (scm_smobs
[smobnum
].free
)
441 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
448 scm_smob_prehistory ()
452 scm_i_pthread_key_create (¤t_mark_stack_pointer
, NULL
);
453 scm_i_pthread_key_create (¤t_mark_stack_limit
, NULL
);
455 smob_gc_kind
= GC_new_kind (GC_new_free_list (),
456 GC_MAKE_PROC (GC_new_proc (smob_mark
), 0),
458 /* Clear new objects. As of version 7.1, libgc
459 doesn't seem to support passing 0 here. */
463 for (i
= 0; i
< MAX_SMOB_COUNT
; ++i
)
465 scm_smobs
[i
].name
= 0;
466 scm_smobs
[i
].size
= 0;
467 scm_smobs
[i
].mark
= 0;
468 scm_smobs
[i
].free
= 0;
469 scm_smobs
[i
].print
= scm_smob_print
;
470 scm_smobs
[i
].equalp
= 0;
471 scm_smobs
[i
].apply
= 0;
472 scm_smobs
[i
].apply_trampoline
= SCM_BOOL_F
;