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_unlocked ("#<", port
);
110 scm_puts_unlocked (SCM_SMOBNAME (n
) ? SCM_SMOBNAME (n
) : "smob", port
);
111 scm_putc_unlocked (' ', 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_unlocked ('>', 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 scm_smobs
[SCM_TC2SMOBNUM (tc
)].apply_trampoline
= trampoline
;
263 if (SCM_UNPACK (scm_smob_class
[0]) != 0)
264 scm_i_inherit_applicable (scm_smob_class
[SCM_TC2SMOBNUM (tc
)]);
268 scm_make_smob (scm_t_bits tc
)
270 scm_t_bits n
= SCM_TC2SMOBNUM (tc
);
271 size_t size
= scm_smobs
[n
].size
;
272 scm_t_bits data
= (size
> 0
273 ? (scm_t_bits
) scm_gc_malloc (size
, SCM_SMOBNAME (n
))
276 SCM_RETURN_NEWSMOB (tc
, data
);
281 /* Marking SMOBs using user-supplied mark procedures. */
284 /* The GC kind used for SMOB types that provide a custom mark procedure. */
285 static int smob_gc_kind
;
287 /* Mark stack pointer and limit, used by `scm_gc_mark'. */
288 static scm_i_pthread_key_t current_mark_stack_pointer
;
289 static scm_i_pthread_key_t current_mark_stack_limit
;
292 /* The generic SMOB mark procedure that gets called for SMOBs allocated
293 with smob_gc_kind. */
294 static struct GC_ms_entry
*
295 smob_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
296 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
299 register scm_t_bits tc
, smobnum
;
301 cell
= SCM_PACK_POINTER (addr
);
303 if (SCM_TYP7 (cell
) != scm_tc7_smob
)
304 /* It is likely that the GC passed us a pointer to a free-list element
305 which we must ignore (see warning in `gc/gc_mark.h'). */
306 return mark_stack_ptr
;
308 tc
= SCM_CELL_WORD_0 (cell
);
309 smobnum
= SCM_TC2SMOBNUM (tc
);
311 if (smobnum
>= scm_numsmob
)
312 /* The first word looks corrupt. */
315 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell
)),
317 mark_stack_limit
, NULL
);
318 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell
)),
320 mark_stack_limit
, NULL
);
321 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell
)),
323 mark_stack_limit
, NULL
);
325 if (scm_smobs
[smobnum
].mark
)
329 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
330 scm_i_pthread_setspecific (current_mark_stack_limit
, mark_stack_limit
);
332 /* Invoke the SMOB's mark procedure, which will in turn invoke
333 `scm_gc_mark', which may modify `current_mark_stack_pointer'. */
334 obj
= scm_smobs
[smobnum
].mark (cell
);
336 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
338 if (SCM_HEAP_OBJECT_P (obj
))
339 /* Mark the returned object. */
340 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (obj
),
342 mark_stack_limit
, NULL
);
344 scm_i_pthread_setspecific (current_mark_stack_pointer
, NULL
);
345 scm_i_pthread_setspecific (current_mark_stack_limit
, NULL
);
348 return mark_stack_ptr
;
352 /* Mark object O. We assume that this function is only called during the mark
353 phase, i.e., from within `smob_mark' or one of its descendants. */
357 if (SCM_HEAP_OBJECT_P (o
))
359 void *mark_stack_ptr
, *mark_stack_limit
;
361 mark_stack_ptr
= scm_i_pthread_getspecific (current_mark_stack_pointer
);
362 mark_stack_limit
= scm_i_pthread_getspecific (current_mark_stack_limit
);
364 if (mark_stack_ptr
== NULL
)
365 /* The function was not called from a mark procedure. */
368 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (o
),
369 mark_stack_ptr
, mark_stack_limit
,
371 scm_i_pthread_setspecific (current_mark_stack_pointer
, mark_stack_ptr
);
376 /* Finalize SMOB by calling its SMOB type's free function, if any. */
378 finalize_smob (void *ptr
, void *data
)
381 size_t (* free_smob
) (SCM
);
383 smob
= SCM_PACK_POINTER (ptr
);
385 printf ("finalizing SMOB %p (smobnum: %u)\n",
386 ptr
, SCM_SMOBNUM (smob
));
389 free_smob
= scm_smobs
[SCM_SMOBNUM (smob
)].free
;
394 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
395 provide a custom mark procedure and it will be honored. */
397 scm_i_new_smob (scm_t_bits tc
, scm_t_bits data
)
399 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
402 /* Use the smob_gc_kind if needed to allow the mark procedure to
403 run. Since the marker only deals with double cells, that case
404 allocates a double cell. We leave words 2 and 3 to there initial
405 values, which is 0. */
406 if (scm_smobs
[smobnum
].mark
)
407 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
409 ret
= SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell
)));
411 SCM_SET_CELL_WORD_1 (ret
, data
);
412 SCM_SET_CELL_WORD_0 (ret
, tc
);
414 if (scm_smobs
[smobnum
].free
)
415 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
420 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
421 provide a custom mark procedure and it will be honored. */
423 scm_i_new_double_smob (scm_t_bits tc
, scm_t_bits data1
,
424 scm_t_bits data2
, scm_t_bits data3
)
426 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
429 /* Use the smob_gc_kind if needed to allow the mark procedure to
431 if (scm_smobs
[smobnum
].mark
)
432 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
434 ret
= SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell
)));
436 SCM_SET_CELL_WORD_3 (ret
, data3
);
437 SCM_SET_CELL_WORD_2 (ret
, data2
);
438 SCM_SET_CELL_WORD_1 (ret
, data1
);
439 SCM_SET_CELL_WORD_0 (ret
, tc
);
441 if (scm_smobs
[smobnum
].free
)
442 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
449 scm_smob_prehistory ()
453 scm_i_pthread_key_create (¤t_mark_stack_pointer
, NULL
);
454 scm_i_pthread_key_create (¤t_mark_stack_limit
, NULL
);
456 smob_gc_kind
= GC_new_kind (GC_new_free_list (),
457 GC_MAKE_PROC (GC_new_proc (smob_mark
), 0),
459 /* Clear new objects. As of version 7.1, libgc
460 doesn't seem to support passing 0 here. */
464 for (i
= 0; i
< MAX_SMOB_COUNT
; ++i
)
466 scm_smobs
[i
].name
= 0;
467 scm_smobs
[i
].size
= 0;
468 scm_smobs
[i
].mark
= 0;
469 scm_smobs
[i
].free
= 0;
470 scm_smobs
[i
].print
= scm_smob_print
;
471 scm_smobs
[i
].equalp
= 0;
472 scm_smobs
[i
].apply
= 0;
473 scm_smobs
[i
].apply_trampoline
= SCM_BOOL_F
;