Commit | Line | Data |
---|---|---|
c8a1bdc4 HWN |
1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. |
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 | |
15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
16 | */ | |
c8a1bdc4 HWN |
17 | |
18 | ||
be3ff021 | 19 | #include <stdio.h> |
660e30c5 | 20 | #include <gmp.h> |
be3ff021 | 21 | |
c8a1bdc4 HWN |
22 | #include "libguile/_scm.h" |
23 | #include "libguile/eval.h" | |
24 | #include "libguile/stime.h" | |
25 | #include "libguile/stackchk.h" | |
26 | #include "libguile/struct.h" | |
27 | #include "libguile/smob.h" | |
28 | #include "libguile/unif.h" | |
29 | #include "libguile/async.h" | |
30 | #include "libguile/ports.h" | |
31 | #include "libguile/root.h" | |
32 | #include "libguile/strings.h" | |
33 | #include "libguile/vectors.h" | |
34 | #include "libguile/weaks.h" | |
35 | #include "libguile/hashtab.h" | |
36 | #include "libguile/tags.h" | |
37 | #include "libguile/private-gc.h" | |
38 | #include "libguile/validate.h" | |
39 | #include "libguile/deprecation.h" | |
40 | #include "libguile/gc.h" | |
41 | ||
42 | ||
43 | #include "libguile/private-gc.h" | |
44 | ||
45 | long int scm_i_deprecated_memory_return; | |
46 | ||
47 | ||
ffd72400 HWN |
48 | /* During collection, this accumulates structures which are to be freed. |
49 | */ | |
50 | SCM scm_i_structs_to_free; | |
51 | ||
52 | ||
c8a1bdc4 HWN |
53 | /* |
54 | Init all the free cells in CARD, prepending to *FREE_LIST. | |
55 | ||
56 | Return: number of free cells found in this card. | |
57 | ||
58 | It would be cleaner to have a separate function sweep_value(), but | |
59 | that is too slow (functions with switch statements can't be | |
60 | inlined). | |
06e80f59 HWN |
61 | |
62 | ||
63 | ||
c8a1bdc4 | 64 | |
06e80f59 HWN |
65 | NOTE: |
66 | ||
67 | This function is quite efficient. However, for many types of cells, | |
68 | allocation and a de-allocation involves calling malloc() and | |
69 | free(). | |
c8a1bdc4 | 70 | |
06e80f59 HWN |
71 | This is costly for small objects (due to malloc/free overhead.) |
72 | (should measure this). | |
73 | ||
74 | It might also be bad for threads: if several threads are allocating | |
75 | strings concurrently, then mallocs for both threads may have to | |
76 | fiddle with locks. | |
77 | ||
78 | It might be interesting to add a separate memory pool for small | |
79 | objects to each freelist. | |
80 | ||
81 | --hwn. | |
82 | */ | |
c8a1bdc4 | 83 | int |
1383773b | 84 | scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) |
c8a1bdc4 HWN |
85 | #define FUNC_NAME "sweep_card" |
86 | { | |
87 | scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p); | |
88 | scm_t_cell * end = p + SCM_GC_CARD_N_CELLS; | |
1383773b | 89 | int span = seg->span; |
c8a1bdc4 HWN |
90 | int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span); |
91 | int free_count = 0; | |
92 | ||
eab1b259 HWN |
93 | ++ scm_gc_running_p; |
94 | ||
c8a1bdc4 HWN |
95 | /* |
96 | I tried something fancy with shifting by one bit every word from | |
97 | the bitvec in turn, but it wasn't any faster, but quite bit | |
98 | hairier. | |
99 | */ | |
100 | for (p += offset; p < end; p += span, offset += span) | |
101 | { | |
102 | SCM scmptr = PTR2SCM(p); | |
103 | if (SCM_C_BVEC_GET (bitvec, offset)) | |
104 | continue; | |
105 | ||
106 | switch (SCM_TYP7 (scmptr)) | |
107 | { | |
108 | case scm_tcs_struct: | |
b4a1358c MD |
109 | /* The card can be swept more than once. Check that it's |
110 | * the first time! | |
111 | */ | |
112 | if (!SCM_STRUCT_GC_CHAIN (p)) | |
113 | { | |
114 | /* Structs need to be freed in a special order. | |
115 | * This is handled by GC C hooks in struct.c. | |
116 | */ | |
117 | SCM_SET_STRUCT_GC_CHAIN (p, scm_i_structs_to_free); | |
118 | scm_i_structs_to_free = scmptr; | |
119 | } | |
c8a1bdc4 HWN |
120 | continue; |
121 | ||
122 | case scm_tcs_cons_imcar: | |
123 | case scm_tcs_cons_nimcar: | |
124 | case scm_tcs_closures: | |
125 | case scm_tc7_pws: | |
126 | break; | |
127 | case scm_tc7_wvect: | |
128 | case scm_tc7_vector: | |
129 | { | |
130 | unsigned long int length = SCM_VECTOR_LENGTH (scmptr); | |
131 | if (length > 0) | |
132 | { | |
133 | scm_gc_free (SCM_VECTOR_BASE (scmptr), | |
134 | length * sizeof (scm_t_bits), | |
135 | "vector"); | |
136 | } | |
137 | break; | |
138 | } | |
139 | #ifdef CCLO | |
140 | case scm_tc7_cclo: | |
141 | scm_gc_free (SCM_CCLO_BASE (scmptr), | |
142 | SCM_CCLO_LENGTH (scmptr) * sizeof (SCM), | |
143 | "compiled closure"); | |
144 | break; | |
145 | #endif | |
c7df0739 | 146 | #if SCM_HAVE_ARRAYS |
c8a1bdc4 HWN |
147 | case scm_tc7_bvect: |
148 | { | |
149 | unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); | |
150 | if (length > 0) | |
151 | { | |
152 | scm_gc_free (SCM_BITVECTOR_BASE (scmptr), | |
153 | (sizeof (long) | |
154 | * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)), | |
155 | "vector"); | |
156 | } | |
157 | } | |
158 | break; | |
159 | case scm_tc7_byvect: | |
160 | case scm_tc7_ivect: | |
161 | case scm_tc7_uvect: | |
162 | case scm_tc7_svect: | |
5264ca4a | 163 | #if SCM_SIZEOF_LONG_LONG != 0 |
c8a1bdc4 HWN |
164 | case scm_tc7_llvect: |
165 | #endif | |
166 | case scm_tc7_fvect: | |
167 | case scm_tc7_dvect: | |
168 | case scm_tc7_cvect: | |
169 | scm_gc_free (SCM_UVECTOR_BASE (scmptr), | |
170 | (SCM_UVECTOR_LENGTH (scmptr) | |
171 | * scm_uniform_element_size (scmptr)), | |
172 | "vector"); | |
173 | break; | |
174 | #endif | |
175 | case scm_tc7_string: | |
176 | scm_gc_free (SCM_STRING_CHARS (scmptr), | |
177 | SCM_STRING_LENGTH (scmptr) + 1, "string"); | |
178 | break; | |
179 | case scm_tc7_symbol: | |
180 | scm_gc_free (SCM_SYMBOL_CHARS (scmptr), | |
181 | SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol"); | |
182 | break; | |
183 | case scm_tc7_variable: | |
184 | break; | |
185 | case scm_tcs_subrs: | |
186 | /* the various "subrs" (primitives) are never freed */ | |
187 | continue; | |
188 | case scm_tc7_port: | |
189 | if SCM_OPENP (scmptr) | |
190 | { | |
191 | int k = SCM_PTOBNUM (scmptr); | |
192 | size_t mm; | |
193 | #if (SCM_DEBUG_CELL_ACCESSES == 1) | |
194 | if (!(k < scm_numptob)) | |
be3ff021 HWN |
195 | { |
196 | fprintf (stderr, "undefined port type"); | |
197 | abort(); | |
198 | } | |
c8a1bdc4 HWN |
199 | #endif |
200 | /* Keep "revealed" ports alive. */ | |
201 | if (scm_revealed_count (scmptr) > 0) | |
202 | continue; | |
203 | ||
204 | /* Yes, I really do mean scm_ptobs[k].free */ | |
205 | /* rather than ftobs[k].close. .close */ | |
206 | /* is for explicit CLOSE-PORT by user */ | |
207 | mm = scm_ptobs[k].free (scmptr); | |
208 | ||
209 | if (mm != 0) | |
210 | { | |
211 | #if SCM_ENABLE_DEPRECATED == 1 | |
212 | scm_c_issue_deprecation_warning | |
213 | ("Returning non-0 from a port free function is " | |
214 | "deprecated. Use scm_gc_free et al instead."); | |
215 | scm_c_issue_deprecation_warning_fmt | |
216 | ("(You just returned non-0 while freeing a %s.)", | |
217 | SCM_PTOBNAME (k)); | |
218 | scm_i_deprecated_memory_return += mm; | |
219 | #else | |
220 | abort (); | |
221 | #endif | |
222 | } | |
223 | ||
224 | SCM_SETSTREAM (scmptr, 0); | |
225 | scm_remove_from_port_table (scmptr); | |
226 | scm_gc_ports_collected++; | |
227 | SCM_CLR_PORT_OPEN_FLAG (scmptr); | |
228 | } | |
229 | break; | |
230 | case scm_tc7_smob: | |
231 | switch SCM_TYP16 (scmptr) | |
232 | { | |
233 | case scm_tc_free_cell: | |
234 | case scm_tc16_real: | |
235 | break; | |
660e30c5 RB |
236 | case scm_tc16_big: |
237 | mpz_clear (SCM_I_BIG_MPZ (scmptr)); | |
238 | /* nothing else to do here since the mpz is in a double cell */ | |
239 | break; | |
c8a1bdc4 HWN |
240 | case scm_tc16_complex: |
241 | scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double), | |
242 | "complex"); | |
243 | break; | |
244 | default: | |
245 | { | |
246 | int k; | |
247 | k = SCM_SMOBNUM (scmptr); | |
248 | #if (SCM_DEBUG_CELL_ACCESSES == 1) | |
249 | if (!(k < scm_numsmob)) | |
be3ff021 HWN |
250 | { |
251 | fprintf (stderr, "undefined smob type"); | |
252 | abort(); | |
253 | } | |
c8a1bdc4 HWN |
254 | #endif |
255 | if (scm_smobs[k].free) | |
256 | { | |
257 | size_t mm; | |
258 | mm = scm_smobs[k].free (scmptr); | |
259 | if (mm != 0) | |
260 | { | |
261 | #if SCM_ENABLE_DEPRECATED == 1 | |
262 | scm_c_issue_deprecation_warning | |
263 | ("Returning non-0 from a smob free function is " | |
264 | "deprecated. Use scm_gc_free et al instead."); | |
265 | scm_c_issue_deprecation_warning_fmt | |
266 | ("(You just returned non-0 while freeing a %s.)", | |
267 | SCM_SMOBNAME (k)); | |
268 | scm_i_deprecated_memory_return += mm; | |
269 | #else | |
270 | abort(); | |
271 | #endif | |
272 | } | |
273 | } | |
274 | break; | |
275 | } | |
276 | } | |
277 | break; | |
278 | default: | |
be3ff021 HWN |
279 | fprintf (stderr, "unknown type"); |
280 | abort(); | |
c8a1bdc4 HWN |
281 | } |
282 | ||
283 | ||
284 | SCM_SET_CELL_TYPE (p, scm_tc_free_cell); | |
285 | SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list)); | |
286 | *free_list = PTR2SCM (p); | |
287 | free_count ++; | |
288 | } | |
eab1b259 HWN |
289 | |
290 | --scm_gc_running_p; | |
c8a1bdc4 HWN |
291 | return free_count; |
292 | } | |
293 | #undef FUNC_NAME | |
294 | ||
295 | ||
296 | /* | |
297 | Like sweep, but no complicated logic to do the sweeping. | |
298 | */ | |
299 | int | |
1383773b HWN |
300 | scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list, |
301 | scm_t_heap_segment*seg) | |
c8a1bdc4 | 302 | { |
1383773b | 303 | int span = seg->span; |
c8a1bdc4 HWN |
304 | scm_t_cell *end = card + SCM_GC_CARD_N_CELLS; |
305 | scm_t_cell *p = end - span; | |
306 | ||
1383773b HWN |
307 | scm_t_c_bvec_long * bvec_ptr = (scm_t_c_bvec_long* ) seg->bounds[1]; |
308 | int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; | |
309 | ||
310 | bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS; | |
311 | SCM_GC_CELL_BVEC (card) = bvec_ptr; | |
312 | ||
c8a1bdc4 HWN |
313 | /* |
314 | ASSUMPTION: n_header_cells <= 2. | |
315 | */ | |
316 | for (; p > card; p -= span) | |
317 | { | |
318 | SCM_SET_CELL_TYPE (p, scm_tc_free_cell); | |
319 | SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list)); | |
320 | *free_list = PTR2SCM (p); | |
321 | } | |
322 | ||
323 | return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS); | |
324 | } | |
325 | ||
326 | ||
1e71eafb HWN |
327 | #if (SCM_DEBUG_CELL_ACCESSES == 1) |
328 | int | |
329 | scm_gc_marked_p (SCM obj) | |
330 | { | |
331 | return SCM_GC_MARK_P(obj); | |
332 | } | |
333 | #endif | |
eab1b259 | 334 | |
c8a1bdc4 HWN |
335 | #if 0 |
336 | /* | |
337 | These functions are meant to be called from GDB as a debug aid. | |
338 | ||
1383773b | 339 | I've left them as a convenience for future generations. --hwn. |
c8a1bdc4 HWN |
340 | */ |
341 | ||
342 | ||
343 | int scm_gc_marked_p (SCM obj); | |
344 | scm_t_cell * scm_gc_get_card (SCM obj); | |
345 | long * scm_gc_get_bvec (SCM obj); | |
346 | ||
347 | typedef struct scm_t_list_cell_struct { | |
348 | scm_t_bits car; | |
349 | struct scm_t_list_cell_struct * cdr; | |
350 | } scm_t_list_cell; | |
351 | ||
eab1b259 HWN |
352 | |
353 | typedef struct scm_t_double_cell | |
354 | { | |
355 | scm_t_bits word_0; | |
356 | scm_t_bits word_1; | |
357 | scm_t_bits word_2; | |
358 | scm_t_bits word_3; | |
359 | } scm_t_double_cell; | |
360 | ||
361 | ||
c8a1bdc4 HWN |
362 | |
363 | scm_t_cell * | |
364 | scm_gc_get_card (SCM obj) | |
365 | { | |
366 | return SCM_GC_CELL_CARD(obj); | |
367 | } | |
368 | ||
369 | long * | |
370 | scm_gc_get_bvec (SCM obj) | |
371 | { | |
372 | return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj)); | |
373 | } | |
374 | #endif |