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