1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
31 #include "libguile/async.h"
32 #include "libguile/goops.h"
33 #include "libguile/instructions.h"
34 #include "libguile/objcodes.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_CRITICAL_SECTION_START
;
209 new_smob
= scm_numsmob
;
210 if (scm_numsmob
!= MAX_SMOB_COUNT
)
212 SCM_CRITICAL_SECTION_END
;
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
;
287 /* The generic SMOB mark procedure that gets called for SMOBs allocated
288 with smob_gc_kind. */
289 static struct GC_ms_entry
*
290 smob_mark (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
291 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
294 register scm_t_bits tc
, smobnum
;
296 cell
= SCM_PACK_POINTER (addr
);
298 if (SCM_TYP7 (cell
) != scm_tc7_smob
)
299 /* It is likely that the GC passed us a pointer to a free-list element
300 which we must ignore (see warning in `gc/gc_mark.h'). */
301 return mark_stack_ptr
;
303 tc
= SCM_CELL_WORD_0 (cell
);
304 smobnum
= SCM_TC2SMOBNUM (tc
);
306 if (smobnum
>= scm_numsmob
)
307 /* The first word looks corrupt. */
310 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell
)),
312 mark_stack_limit
, NULL
);
313 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell
)),
315 mark_stack_limit
, NULL
);
316 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell
)),
318 mark_stack_limit
, NULL
);
320 if (scm_smobs
[smobnum
].mark
)
324 SCM_I_CURRENT_THREAD
->current_mark_stack_ptr
= mark_stack_ptr
;
325 SCM_I_CURRENT_THREAD
->current_mark_stack_limit
= mark_stack_limit
;
327 /* Invoke the SMOB's mark procedure, which will in turn invoke
328 `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */
329 obj
= scm_smobs
[smobnum
].mark (cell
);
331 mark_stack_ptr
= SCM_I_CURRENT_THREAD
->current_mark_stack_ptr
;
333 if (SCM_HEAP_OBJECT_P (obj
))
334 /* Mark the returned object. */
335 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (obj
),
337 mark_stack_limit
, NULL
);
339 SCM_I_CURRENT_THREAD
->current_mark_stack_limit
= NULL
;
340 SCM_I_CURRENT_THREAD
->current_mark_stack_ptr
= NULL
;
343 return mark_stack_ptr
;
347 /* Mark object O. We assume that this function is only called during the
348 mark phase, i.e., from within `smob_mark ()' or one of its
353 #define CURRENT_MARK_PTR \
354 ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
355 #define CURRENT_MARK_LIMIT \
356 ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
358 if (SCM_HEAP_OBJECT_P (o
))
360 /* At this point, the `current_mark_*' fields of the current thread
361 must be defined (they are set in `smob_mark ()'). */
362 register struct GC_ms_entry
*mark_stack_ptr
;
364 if (!CURRENT_MARK_PTR
)
365 /* The function was not called from a mark procedure. */
368 mark_stack_ptr
= GC_MARK_AND_PUSH (SCM2PTR (o
),
369 CURRENT_MARK_PTR
, CURRENT_MARK_LIMIT
,
371 SCM_I_CURRENT_THREAD
->current_mark_stack_ptr
= mark_stack_ptr
;
373 #undef CURRENT_MARK_PTR
374 #undef CURRENT_MARK_LIMIT
378 /* Finalize SMOB by calling its SMOB type's free function, if any. */
380 finalize_smob (void *ptr
, void *data
)
383 size_t (* free_smob
) (SCM
);
385 smob
= SCM_PACK_POINTER (ptr
);
387 printf ("finalizing SMOB %p (smobnum: %u)\n",
388 ptr
, SCM_SMOBNUM (smob
));
391 free_smob
= scm_smobs
[SCM_SMOBNUM (smob
)].free
;
396 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
397 provide a custom mark procedure and it will be honored. */
399 scm_i_new_smob (scm_t_bits tc
, scm_t_bits data
)
401 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
404 /* Use the smob_gc_kind if needed to allow the mark procedure to
405 run. Since the marker only deals with double cells, that case
406 allocates a double cell. We leave words 2 and 3 to there initial
407 values, which is 0. */
408 if (scm_smobs
[smobnum
].mark
)
409 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
411 ret
= SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell
)));
413 SCM_SET_CELL_WORD_1 (ret
, data
);
414 SCM_SET_CELL_WORD_0 (ret
, tc
);
416 if (scm_smobs
[smobnum
].free
)
417 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
422 /* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
423 provide a custom mark procedure and it will be honored. */
425 scm_i_new_double_smob (scm_t_bits tc
, scm_t_bits data1
,
426 scm_t_bits data2
, scm_t_bits data3
)
428 scm_t_bits smobnum
= SCM_TC2SMOBNUM (tc
);
431 /* Use the smob_gc_kind if needed to allow the mark procedure to
433 if (scm_smobs
[smobnum
].mark
)
434 ret
= SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell
), smob_gc_kind
));
436 ret
= SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell
)));
438 SCM_SET_CELL_WORD_3 (ret
, data3
);
439 SCM_SET_CELL_WORD_2 (ret
, data2
);
440 SCM_SET_CELL_WORD_1 (ret
, data1
);
441 SCM_SET_CELL_WORD_0 (ret
, tc
);
443 if (scm_smobs
[smobnum
].free
)
444 scm_i_set_finalizer (SCM2PTR (ret
), finalize_smob
, NULL
);
451 scm_smob_prehistory ()
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
;