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/objcodes.h"
36 #include "libguile/programs.h"
38 #include "libguile/smob.h"
40 #include "libguile/bdw-gc.h"
41 #include <gc/gc_mark.h>
46 /* scm_smobs scm_numsmob
47 * implement a fixed sized array of smob records.
48 * Indexes into this table are used when generating type
49 * tags for smobjects (if you know a tag you can get an index and conversely).
52 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
55 scm_smob_descriptor scm_smobs
[MAX_SMOB_COUNT
];
58 scm_assert_smob_type (scm_t_bits tag
, SCM val
)
60 if (!SCM_SMOB_PREDICATE (tag
, val
))
61 scm_wrong_type_arg_msg (NULL
, 0, val
, scm_smobs
[SCM_TC2SMOBNUM(tag
)].name
);
67 /* This function is vestigial. It used to be the mark function's
68 responsibility to set the mark bit on the smob or port, but now the
69 generic marking routine in gc.c takes care of that, and a zero
70 pointer for a mark function means "don't bother". So you never
73 However, we leave it here because it's harmless to call it, and
74 people out there have smob code that uses it, and there's no reason
75 to make their links fail. */
78 scm_mark0 (SCM ptr SCM_UNUSED
)
84 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
85 be used for real pairs. */
88 return SCM_CELL_OBJECT_1 (ptr
);
96 scm_free0 (SCM ptr SCM_UNUSED
)
106 scm_smob_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
108 long n
= SCM_SMOBNUM (exp
);
109 scm_puts ("#<", port
);
110 scm_puts (SCM_SMOBNAME (n
) ? SCM_SMOBNAME (n
) : "smob", port
);
111 scm_putc (' ', port
);
112 if (scm_smobs
[n
].size
)
113 scm_uintprint (SCM_CELL_WORD_1 (exp
), 16, port
);
115 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
116 scm_putc ('>', port
);
124 static SCM scm_smob_trampolines
[16];
126 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
127 #define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
128 scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
129 + nopt + rest * (nreq + nopt + rest + 1)]
134 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
139 apply_1 (SCM smob
, SCM a
)
141 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
142 return subr (smob
, a
);
146 apply_2 (SCM smob
, SCM a
, SCM b
)
148 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
149 return subr (smob
, a
, b
);
153 apply_3 (SCM smob
, SCM a
, SCM b
, SCM c
)
155 SCM (*subr
)() = SCM_SMOB_DESCRIPTOR (smob
).apply
;
156 return subr (smob
, a
, b
, c
);
160 scm_smob_trampoline (unsigned int nreq
, unsigned int nopt
,
165 if (SCM_UNLIKELY (rest
> 1 || nreq
+ nopt
+ rest
> 3))
166 scm_out_of_range ("make-smob", scm_from_uint (nreq
+ nopt
+ rest
));
168 trampoline
= SCM_SMOB_TRAMPOLINE (nreq
, nopt
, rest
);
170 if (SCM_LIKELY (SCM_UNPACK (trampoline
)))
173 switch (nreq
+ nopt
+ rest
)
175 /* The + 1 is for the smob itself. */
177 trampoline
= scm_c_make_gsubr ("apply-smob/0", nreq
+ 1, nopt
, rest
,
181 trampoline
= scm_c_make_gsubr ("apply-smob/1", nreq
+ 1, nopt
, rest
,
185 trampoline
= scm_c_make_gsubr ("apply-smob/2", nreq
+ 1, nopt
, rest
,
189 trampoline
= scm_c_make_gsubr ("apply-smob/3", nreq
+ 1, nopt
, rest
,
196 SCM_SMOB_TRAMPOLINE (nreq
, nopt
, rest
) = trampoline
;
204 scm_make_smob_type (char const *name
, size_t size
)
205 #define FUNC_NAME "scm_make_smob_type"
209 SCM_CRITICAL_SECTION_START
;
210 new_smob
= scm_numsmob
;
211 if (scm_numsmob
!= MAX_SMOB_COUNT
)
213 SCM_CRITICAL_SECTION_END
;
215 if (new_smob
== MAX_SMOB_COUNT
)
216 scm_misc_error (FUNC_NAME
, "maximum number of smobs exceeded", SCM_EOL
);
218 scm_smobs
[new_smob
].name
= name
;
219 scm_smobs
[new_smob
].size
= size
;
221 /* Make a class object if Goops is present. */
222 if (SCM_UNPACK (scm_smob_class
[0]) != 0)
223 scm_smob_class
[new_smob
] = scm_make_extended_class (name
, 0);
225 return scm_tc7_smob
+ new_smob
* 256;
231 scm_set_smob_mark (scm_t_bits tc
, SCM (*mark
) (SCM
))
233 scm_smobs
[SCM_TC2SMOBNUM (tc
)].mark
= mark
;
237 scm_set_smob_free (scm_t_bits tc
, size_t (*free
) (SCM
))
239 scm_smobs
[SCM_TC2SMOBNUM (tc
)].free
= free
;
243 scm_set_smob_print (scm_t_bits tc
, int (*print
) (SCM
, SCM
, scm_print_state
*))
245 scm_smobs
[SCM_TC2SMOBNUM (tc
)].print
= print
;
249 scm_set_smob_equalp (scm_t_bits tc
, SCM (*equalp
) (SCM
, SCM
))
251 scm_smobs
[SCM_TC2SMOBNUM (tc
)].equalp
= equalp
;
255 scm_set_smob_apply (scm_t_bits tc
, SCM (*apply
) (),
256 unsigned int req
, unsigned int opt
, unsigned int rst
)
258 SCM trampoline
= scm_smob_trampoline (req
, opt
, rst
);
260 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply
= apply
;
261 /* In 2.2 this field is renamed to "apply_trampoline". */
262 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_trampoline_objcode
= trampoline
;
264 if (SCM_UNPACK (scm_smob_class
[0]) != 0)
265 scm_i_inherit_applicable (scm_smob_class
[SCM_TC2SMOBNUM (tc
)]);
269 scm_make_smob (scm_t_bits tc
)
271 scm_t_bits n
= SCM_TC2SMOBNUM (tc
);
272 size_t size
= scm_smobs
[n
].size
;
273 scm_t_bits data
= (size
> 0
274 ? (scm_t_bits
) scm_gc_malloc (size
, SCM_SMOBNAME (n
))
277 SCM_RETURN_NEWSMOB (tc
, data
);
282 /* Marking SMOBs using user-supplied mark procedures. */
285 /* The GC kind used for SMOB types that provide a custom mark procedure. */
286 static int smob_gc_kind
;
288 /* Mark stack pointer and limit, used by `scm_gc_mark'. */
289 static scm_i_pthread_key_t current_mark_stack_pointer
;
290 static scm_i_pthread_key_t current_mark_stack_limit
;
293 /* The generic SMOB mark procedure that gets called for SMOBs allocated
294 with smob_gc_kind. */
295 static struct GC_ms_entry
*
296 smob_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
297 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
300 register scm_t_bits tc
, smobnum
;
302 cell
= PTR2SCM (addr
);
304 if (SCM_TYP7 (cell
) != scm_tc7_smob
)
305 /* It is likely that the GC passed us a pointer to a free-list element
306 which we must ignore (see warning in `gc/gc_mark.h'). */
307 return mark_stack_ptr
;
309 tc
= SCM_CELL_WORD_0 (cell
);
310 smobnum
= SCM_TC2SMOBNUM (tc
);
312 if (smobnum
>= scm_numsmob
)
313 /* The first word looks corrupt. */
316 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell
)),
318 mark_stack_limit
, NULL
);
319 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell
)),
321 mark_stack_limit
, NULL
);
322 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell
)),
324 mark_stack_limit
, NULL
);
326 if (scm_smobs
[smobnum
].mark
)
330 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
331 scm_i_pthread_setspecific (current_mark_stack_limit
, mark_stack_limit
);
333 /* Invoke the SMOB's mark procedure, which will in turn invoke
334 `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
335 obj
= scm_smobs
[smobnum
].mark (cell
);
337 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
340 /* Mark the returned object. */
341 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (obj
),
343 mark_stack_limit
, NULL
);
345 scm_i_pthread_setspecific (current_mark_stack_pointer
, NULL
);
346 scm_i_pthread_setspecific (current_mark_stack_limit
, NULL
);
349 return mark_stack_ptr
;
353 /* Mark object O. We assume that this function is only called during the mark
354 phase, i.e., from within `smob_mark' or one of its descendants. */
360 void *mark_stack_ptr
, *mark_stack_limit
;
362 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
363 mark_stack_limit
= scm_i_pthread_getspecific (current_mark_stack_limit
);
365 if (mark_stack_ptr
== NULL
)
366 /* The function was not called from a mark procedure. */
369 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (o
),
370 mark_stack_ptr
, mark_stack_limit
,
372 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
377 /* Finalize SMOB by calling its SMOB type's free function, if any. */
379 finalize_smob (void *ptr
, void *data
)
382 size_t (* free_smob
) (SCM
);
384 smob
= PTR2SCM (ptr
);
386 printf ("finalizing SMOB %p (smobnum: %u)\n",
387 ptr
, SCM_SMOBNUM (smob
));
390 free_smob
= scm_smobs
[SCM_SMOBNUM (smob
)].free
;
395 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
396 provide a custom mark procedure and it will be honored. */
398 scm_i_new_smob (scm_t_bits tc
, scm_t_bits data
)
400 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
403 /* Use the smob_gc_kind if needed to allow the mark procedure to
404 run. Since the marker only deals with double cells, that case
405 allocates a double cell. We leave words 2 and 3 to there initial
406 values, which is 0. */
407 if (scm_smobs
[smobnum
].mark
)
408 ret
= PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
410 ret
= PTR2SCM (GC_MALLOC (sizeof (scm_t_cell
)));
412 SCM_SET_CELL_WORD_1 (ret
, data
);
413 SCM_SET_CELL_WORD_0 (ret
, tc
);
415 if (scm_smobs
[smobnum
].free
)
416 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
421 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
422 provide a custom mark procedure and it will be honored. */
424 scm_i_new_double_smob (scm_t_bits tc
, scm_t_bits data1
,
425 scm_t_bits data2
, scm_t_bits data3
)
427 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
430 /* Use the smob_gc_kind if needed to allow the mark procedure to
432 if (scm_smobs
[smobnum
].mark
)
433 ret
= PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
435 ret
= PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell
)));
437 SCM_SET_CELL_WORD_3 (ret
, data3
);
438 SCM_SET_CELL_WORD_2 (ret
, data2
);
439 SCM_SET_CELL_WORD_1 (ret
, data1
);
440 SCM_SET_CELL_WORD_0 (ret
, tc
);
442 if (scm_smobs
[smobnum
].free
)
443 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
451 /* These two are internal details of the previous implementation of
452 SCM_NEWSMOB and are no longer used. They are still here to preserve
453 ABI stability in the 2.0 series. */
455 scm_i_finalize_smob (void *ptr
, void *data
)
457 finalize_smob (ptr
, data
);
461 scm_i_new_smob_with_mark_proc (scm_t_bits tc
, scm_t_bits word1
,
462 scm_t_bits word2
, scm_t_bits word3
)
464 return scm_new_double_smob (tc
, word1
, word2
, word3
);
470 scm_smob_prehistory ()
474 scm_i_pthread_key_create (¤t_mark_stack_pointer
, NULL
);
475 scm_i_pthread_key_create (¤t_mark_stack_limit
, NULL
);
477 smob_gc_kind
= GC_new_kind (GC_new_free_list (),
478 GC_MAKE_PROC (GC_new_proc (smob_mark
), 0),
480 /* Clear new objects. As of version 7.1, libgc
481 doesn't seem to support passing 0 here. */
485 for (i
= 0; i
< MAX_SMOB_COUNT
; ++i
)
487 scm_smobs
[i
].name
= 0;
488 scm_smobs
[i
].size
= 0;
489 scm_smobs
[i
].mark
= 0;
490 scm_smobs
[i
].free
= 0;
491 scm_smobs
[i
].print
= scm_smob_print
;
492 scm_smobs
[i
].equalp
= 0;
493 scm_smobs
[i
].apply
= 0;
494 scm_smobs
[i
].apply_trampoline_objcode
= SCM_BOOL_F
;