1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful,
9 * but 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.
12 *
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 02110-1301 USA
16 */
17
18 #ifdef HAVE_CONFIG_H
19 # include <config.h>
20 #endif
21
22 #include <stdio.h>
23 #include <gmp.h>
24
25 #include "libguile/_scm.h"
26 #include "libguile/eval.h"
27 #include "libguile/numbers.h"
28 #include "libguile/stime.h"
29 #include "libguile/stackchk.h"
30 #include "libguile/struct.h"
31 #include "libguile/smob.h"
32 #include "libguile/unif.h"
33 #include "libguile/async.h"
34 #include "libguile/ports.h"
35 #include "libguile/root.h"
36 #include "libguile/strings.h"
37 #include "libguile/vectors.h"
38 #include "libguile/weaks.h"
39 #include "libguile/hashtab.h"
40 #include "libguile/tags.h"
41 #include "libguile/private-gc.h"
42 #include "libguile/validate.h"
43 #include "libguile/deprecation.h"
44 #include "libguile/gc.h"
45 #include "libguile/srfi-4.h"
46
47 #include "libguile/private-gc.h"
48
49 long int scm_i_deprecated_memory_return;
50
51
52 /* During collection, this accumulates structures which are to be freed.
53 */
54 SCM scm_i_structs_to_free;
55
56
57 /*
58 Init all the free cells in CARD, prepending to *FREE_LIST.
59
60 Return: number of free cells found in this card.
61
62 It would be cleaner to have a separate function sweep_value(), but
63 that is too slow (functions with switch statements can't be
64 inlined).
65
66
67
68
69 NOTE:
70
71 This function is quite efficient. However, for many types of cells,
72 allocation and a de-allocation involves calling malloc() and
73 free().
74
75 This is costly for small objects (due to malloc/free overhead.)
76 (should measure this).
77
78 It might also be bad for threads: if several threads are allocating
79 strings concurrently, then mallocs for both threads may have to
80 fiddle with locks.
81
82 It might be interesting to add a separate memory pool for small
83 objects to each freelist.
84
85 --hwn.
86 */
87 int
scm_i_sweep_card(scm_t_cell * p,SCM * free_list,scm_t_heap_segment * seg)88 scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg)
89 #define FUNC_NAME "sweep_card"
90 {
91 scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
92 scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
93 int span = seg->span;
94 int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
95 int free_count = 0;
96
97 /*
98 I tried something fancy with shifting by one bit every word from
99 the bitvec in turn, but it wasn't any faster, but quite a bit
100 hairier.
101 */
102 for (p += offset; p < end; p += span, offset += span)
103 {
104 SCM scmptr = PTR2SCM (p);
105 if (SCM_C_BVEC_GET (bitvec, offset))
106 continue;
107
108 switch (SCM_TYP7 (scmptr))
109 {
110 case scm_tcs_struct:
111 /* The card can be swept more than once. Check that it's
112 * the first time!
113 */
114 if (!SCM_STRUCT_GC_CHAIN (scmptr))
115 {
116 /* Structs need to be freed in a special order.
117 * This is handled by GC C hooks in struct.c.
118 */
119 SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
120 scm_i_structs_to_free = scmptr;
121 }
122 continue;
123
124 case scm_tcs_cons_imcar:
125 case scm_tcs_cons_nimcar:
126 case scm_tcs_closures:
127 case scm_tc7_pws:
128 break;
129 case scm_tc7_wvect:
130 case scm_tc7_vector:
131 scm_i_vector_free (scmptr);
132 break;
133
134 #ifdef CCLO
135 case scm_tc7_cclo:
136 scm_gc_free (SCM_CCLO_BASE (scmptr),
137 SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
138 "compiled closure");
139 break;
140 #endif
141
142 case scm_tc7_number:
143 switch SCM_TYP16 (scmptr)
144 {
145 case scm_tc16_real:
146 break;
147 case scm_tc16_big:
148 mpz_clear (SCM_I_BIG_MPZ (scmptr));
149 /* nothing else to do here since the mpz is in a double cell */
150 break;
151 case scm_tc16_complex:
152 scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
153 "complex");
154 break;
155 case scm_tc16_fraction:
156 /* nothing to do here since the num/denum of a fraction
157 are proper SCM objects themselves. */
158 break;
159 }
160 break;
161 case scm_tc7_string:
162 scm_i_string_free (scmptr);
163 break;
164 case scm_tc7_stringbuf:
165 scm_i_stringbuf_free (scmptr);
166 break;
167 case scm_tc7_symbol:
168 scm_i_symbol_free (scmptr);
169 break;
170 case scm_tc7_variable:
171 break;
172 case scm_tcs_subrs:
173 /* the various "subrs" (primitives) are never freed */
174 continue;
175 case scm_tc7_port:
176 if SCM_OPENP (scmptr)
177 {
178 int k = SCM_PTOBNUM (scmptr);
179 size_t mm;
180 #if (SCM_DEBUG_CELL_ACCESSES == 1)
181 if (!(k < scm_numptob))
182 {
183 fprintf (stderr, "undefined port type");
184 abort();
185 }
186 #endif
187 /* Keep "revealed" ports alive. */
188 if (scm_revealed_count (scmptr) > 0)
189 continue;
190
191 /* Yes, I really do mean scm_ptobs[k].free */
192 /* rather than ftobs[k].close. .close */
193 /* is for explicit CLOSE-PORT by user */
194 mm = scm_ptobs[k].free (scmptr);
195
196 if (mm != 0)
197 {
198 #if SCM_ENABLE_DEPRECATED == 1
199 scm_c_issue_deprecation_warning
200 ("Returning non-0 from a port free function is "
201 "deprecated. Use scm_gc_free et al instead.");
202 scm_c_issue_deprecation_warning_fmt
203 ("(You just returned non-0 while freeing a %s.)",
204 SCM_PTOBNAME (k));
205 scm_i_deprecated_memory_return += mm;
206 #else
207 abort ();
208 #endif
209 }
210
211 SCM_SETSTREAM (scmptr, 0);
212 scm_remove_from_port_table (scmptr);
213 scm_gc_ports_collected++;
214 SCM_CLR_PORT_OPEN_FLAG (scmptr);
215 }
216 break;
217 case scm_tc7_smob:
218 switch SCM_TYP16 (scmptr)
219 {
220 case scm_tc_free_cell:
221 free_count --;
222 break;
223 default:
224 {
225 int k;
226 k = SCM_SMOBNUM (scmptr);
227 #if (SCM_DEBUG_CELL_ACCESSES == 1)
228 if (!(k < scm_numsmob))
229 {
230 fprintf (stderr, "undefined smob type");
231 abort();
232 }
233 #endif
234 if (scm_smobs[k].free)
235 {
236 size_t mm;
237 mm = scm_smobs[k].free (scmptr);
238 if (mm != 0)
239 {
240 #if SCM_ENABLE_DEPRECATED == 1
241 scm_c_issue_deprecation_warning
242 ("Returning non-0 from a smob free function is "
243 "deprecated. Use scm_gc_free et al instead.");
244 scm_c_issue_deprecation_warning_fmt
245 ("(You just returned non-0 while freeing a %s.)",
246 SCM_SMOBNAME (k));
247 scm_i_deprecated_memory_return += mm;
248 #else
249 abort();
250 #endif
251 }
252 }
253 break;
254 }
255 }
256 break;
257 default:
258 fprintf (stderr, "unknown type");
259 abort();
260 }
261
262 SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
263 SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
264 *free_list = scmptr;
265 free_count ++;
266 }
267
268 return free_count;
269 }
270 #undef FUNC_NAME
271
272
273 /*
274 Like sweep, but no complicated logic to do the sweeping.
275 */
276 int
scm_i_init_card_freelist(scm_t_cell * card,SCM * free_list,scm_t_heap_segment * seg)277 scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
278 scm_t_heap_segment*seg)
279 {
280 int span = seg->span;
281 scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
282 scm_t_cell *p = end - span;
283
284 scm_t_c_bvec_long * bvec_ptr = (scm_t_c_bvec_long* ) seg->bounds[1];
285 int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
286
287 bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
288 SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
289
290 /*
291 ASSUMPTION: n_header_cells <= 2.
292 */
293 for (; p > card; p -= span)
294 {
295 const SCM scmptr = PTR2SCM (p);
296 SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
297 SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
298 *free_list = scmptr;
299 }
300
301 return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
302 }
303
304
305 void
scm_i_card_statistics(scm_t_cell * p,SCM hashtab,scm_t_heap_segment * seg)306 scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
307 {
308 scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
309 scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
310 int span = seg->span;
311 int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
312
313 if (!bitvec)
314 /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
315 return;
316
317 for (p += offset; p < end; p += span, offset += span)
318 {
319 scm_t_bits tag = -1;
320 SCM scmptr = PTR2SCM (p);
321
322 if (!SCM_C_BVEC_GET (bitvec, offset))
323 continue;
324
325 tag = SCM_TYP7 (scmptr);
326 if (tag == scm_tc7_smob || tag == scm_tc7_number)
327 {
328 /* Record smobs and numbers under 16 bits of the tag, so the
329 different smob objects are distinguished, and likewise the
330 different numbers big, real, complex and fraction. */
331 tag = SCM_TYP16(scmptr);
332 }
333 else
334 switch (tag)
335 {
336 case scm_tcs_cons_imcar:
337 tag = scm_tc2_int;
338 break;
339 case scm_tcs_cons_nimcar:
340 tag = scm_tc3_cons;
341 break;
342
343 case scm_tcs_struct:
344 tag = scm_tc3_struct;
345 break;
346 case scm_tcs_closures:
347 tag = scm_tc3_closure;
348 break;
349 case scm_tcs_subrs:
350 tag = scm_tc7_asubr;
351 break;
352 }
353
354 {
355 SCM handle = scm_hashq_create_handle_x (hashtab,
356 scm_from_int (tag), SCM_INUM0);
357 SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
358 }
359 }
360 }
361
362 /* TAG is the tag word of a cell, return a string which is its name, or NULL
363 if unknown. Currently this is only used by gc-live-object-stats and the
364 distinctions between types are oriented towards what that code records
365 while scanning what's alive. */
366 char const *
scm_i_tag_name(scm_t_bits tag)367 scm_i_tag_name (scm_t_bits tag)
368 {
369 switch (tag & 0x7F) /* 7 bits */
370 {
371 case scm_tcs_struct:
372 return "struct";
373 case scm_tcs_cons_imcar:
374 return "cons (immediate car)";
375 case scm_tcs_cons_nimcar:
376 return "cons (non-immediate car)";
377 case scm_tcs_closures:
378 return "closures";
379 case scm_tc7_pws:
380 return "pws";
381 case scm_tc7_wvect:
382 return "weak vector";
383 case scm_tc7_vector:
384 return "vector";
385 #ifdef CCLO
386 case scm_tc7_cclo:
387 return "compiled closure";
388 #endif
389 case scm_tc7_number:
390 switch (tag)
391 {
392 case scm_tc16_real:
393 return "real";
394 case scm_tc16_big:
395 return "bignum";
396 case scm_tc16_complex:
397 return "complex number";
398 case scm_tc16_fraction:
399 return "fraction";
400 }
401 /* shouldn't reach here unless there's a new class of numbers */
402 return "number";
403 case scm_tc7_string:
404 return "string";
405 case scm_tc7_stringbuf:
406 return "string buffer";
407 case scm_tc7_symbol:
408 return "symbol";
409 case scm_tc7_variable:
410 return "variable";
411 case scm_tcs_subrs:
412 return "subrs";
413 case scm_tc7_port:
414 return "port";
415 case scm_tc7_smob:
416 /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
417 entry should be ok for our return here */
418 return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
419 }
420
421 return NULL;
422 }
423
424
425 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
426
427 typedef struct scm_dbg_t_list_cell {
428 scm_t_bits car;
429 struct scm_dbg_t_list_cell * cdr;
430 } scm_dbg_t_list_cell;
431
432
433 typedef struct scm_dbg_t_double_cell {
434 scm_t_bits word_0;
435 scm_t_bits word_1;
436 scm_t_bits word_2;
437 scm_t_bits word_3;
438 } scm_dbg_t_double_cell;
439
440
441 int scm_dbg_gc_marked_p (SCM obj);
442 scm_t_cell * scm_dbg_gc_get_card (SCM obj);
443 scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
444
445
446 int
scm_dbg_gc_marked_p(SCM obj)447 scm_dbg_gc_marked_p (SCM obj)
448 {
449 if (!SCM_IMP (obj))
450 return SCM_GC_MARK_P(obj);
451 else
452 return 0;
453 }
454
455 scm_t_cell *
scm_dbg_gc_get_card(SCM obj)456 scm_dbg_gc_get_card (SCM obj)
457 {
458 if (!SCM_IMP (obj))
459 return SCM_GC_CELL_CARD(obj);
460 else
461 return NULL;
462 }
463
464 scm_t_c_bvec_long *
scm_dbg_gc_get_bvec(SCM obj)465 scm_dbg_gc_get_bvec (SCM obj)
466 {
467 if (!SCM_IMP (obj))
468 return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
469 else
470 return NULL;
471 }
472
473 #endif
474