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