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