90 |
|
|
91 |
unsigned int scm_gc_running_p = 0; |
unsigned int scm_gc_running_p = 0; |
92 |
|
|
|
#if (SCM_DEBUG_CELL_ACCESSES == 1) |
|
|
|
|
93 |
/* Set this to != 0 if every cell that is accessed shall be checked: |
/* Set this to != 0 if every cell that is accessed shall be checked: |
94 |
*/ |
*/ |
95 |
unsigned int scm_debug_cell_accesses_p = 1; |
int scm_debug_cell_accesses_p = 0; |
96 |
|
int scm_expensive_debug_cell_accesses_p = 0; |
97 |
|
|
98 |
/* Set this to 0 if no additional gc's shall be performed, otherwise set it to |
/* Set this to 0 if no additional gc's shall be performed, otherwise set it to |
99 |
* the number of cell accesses after which a gc shall be called. |
* the number of cell accesses after which a gc shall be called. |
100 |
*/ |
*/ |
101 |
static unsigned int debug_cells_gc_interval = 0; |
int scm_debug_cells_gc_interval = 0; |
102 |
|
|
103 |
|
/* |
104 |
/* Assert that the given object is a valid reference to a valid cell. This |
Global variable, so you can switch it off at runtime by setting |
105 |
* test involves to determine whether the object is a cell pointer, whether |
scm_i_cell_validation_already_running. |
|
* this pointer actually points into a heap segment and whether the cell |
|
|
* pointed to is not a free cell. Further, additional garbage collections may |
|
|
* get executed after a user defined number of cell accesses. This helps to |
|
|
* find places in the C code where references are dropped for extremely short |
|
|
* periods. |
|
106 |
*/ |
*/ |
107 |
|
int scm_i_cell_validation_already_running ; |
108 |
|
|
109 |
|
#if (SCM_DEBUG_CELL_ACCESSES == 1) |
110 |
|
|
111 |
|
|
112 |
|
/* |
113 |
|
|
114 |
|
Assert that the given object is a valid reference to a valid cell. This |
115 |
|
test involves to determine whether the object is a cell pointer, whether |
116 |
|
this pointer actually points into a heap segment and whether the cell |
117 |
|
pointed to is not a free cell. Further, additional garbage collections may |
118 |
|
get executed after a user defined number of cell accesses. This helps to |
119 |
|
find places in the C code where references are dropped for extremely short |
120 |
|
periods. |
121 |
|
|
122 |
|
*/ |
123 |
|
|
124 |
|
|
125 |
void |
void |
126 |
scm_assert_cell_valid (SCM cell) |
scm_i_expensive_validation_check (SCM cell) |
127 |
{ |
{ |
128 |
static unsigned int already_running = 0; |
if (!scm_in_heap_p (cell)) |
129 |
|
{ |
130 |
|
fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n", |
131 |
|
(unsigned long) SCM_UNPACK (cell)); |
132 |
|
abort (); |
133 |
|
} |
134 |
|
|
135 |
|
/* If desired, perform additional garbage collections after a user |
136 |
|
* defined number of cell accesses. |
137 |
|
*/ |
138 |
|
if (scm_debug_cells_gc_interval) |
139 |
|
{ |
140 |
|
static unsigned int counter = 0; |
141 |
|
|
142 |
|
if (counter != 0) |
143 |
|
{ |
144 |
|
--counter; |
145 |
|
} |
146 |
|
else |
147 |
|
{ |
148 |
|
counter = scm_debug_cells_gc_interval; |
149 |
|
scm_igc ("scm_assert_cell_valid"); |
150 |
|
} |
151 |
|
} |
152 |
|
} |
153 |
|
|
154 |
if (!already_running) |
void |
155 |
|
scm_assert_cell_valid (SCM cell) |
156 |
|
{ |
157 |
|
if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p) |
158 |
{ |
{ |
159 |
already_running = 1; /* set to avoid recursion */ |
scm_i_cell_validation_already_running = 1; /* set to avoid recursion */ |
160 |
|
|
161 |
/* |
/* |
162 |
During GC, no user-code should be run, and the guile core should |
During GC, no user-code should be run, and the guile core |
163 |
use non-protected accessors. |
should use non-protected accessors. |
164 |
*/ |
*/ |
165 |
if (scm_gc_running_p) |
if (scm_gc_running_p) |
166 |
abort(); |
return; |
167 |
|
|
168 |
/* |
/* |
169 |
Only scm_in_heap_p is wildly expensive. |
Only scm_in_heap_p and rescanning the heap is wildly |
170 |
*/ |
expensive. |
171 |
if (scm_debug_cell_accesses_p) |
*/ |
172 |
if (!scm_in_heap_p (cell)) |
if (scm_expensive_debug_cell_accesses_p) |
173 |
{ |
scm_i_expensive_validation_check (cell); |
|
fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n", |
|
|
(unsigned long) SCM_UNPACK (cell)); |
|
|
abort (); |
|
|
} |
|
174 |
|
|
175 |
if (!SCM_GC_MARK_P (cell)) |
if (!SCM_GC_MARK_P (cell)) |
176 |
{ |
{ |
182 |
abort (); |
abort (); |
183 |
} |
} |
184 |
|
|
185 |
|
scm_i_cell_validation_already_running = 0; /* re-enable */ |
|
/* If desired, perform additional garbage collections after a user |
|
|
* defined number of cell accesses. |
|
|
*/ |
|
|
if (scm_debug_cell_accesses_p && debug_cells_gc_interval) |
|
|
{ |
|
|
static unsigned int counter = 0; |
|
|
|
|
|
if (counter != 0) |
|
|
{ |
|
|
--counter; |
|
|
} |
|
|
else |
|
|
{ |
|
|
counter = debug_cells_gc_interval; |
|
|
scm_igc ("scm_assert_cell_valid"); |
|
|
} |
|
|
} |
|
|
already_running = 0; /* re-enable */ |
|
186 |
} |
} |
187 |
} |
} |
188 |
|
|
189 |
|
|
190 |
|
|
191 |
SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, |
SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, |
192 |
(SCM flag), |
(SCM flag), |
193 |
"If @var{flag} is @code{#f}, cell access checking is disabled.\n" |
"If @var{flag} is @code{#f}, cell access checking is disabled.\n" |
194 |
"If @var{flag} is @code{#t}, cell access checking is enabled,\n" |
"If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n" |
195 |
"but no additional calls to garbage collection are issued.\n" |
"but no additional calls to garbage collection are issued.\n" |
196 |
"If @var{flag} is a number, cell access checking is enabled,\n" |
"If @var{flag} is a number, strict cell access checking is enabled,\n" |
197 |
"with an additional garbage collection after the given\n" |
"with an additional garbage collection after the given\n" |
198 |
"number of cell accesses.\n" |
"number of cell accesses.\n" |
199 |
"This procedure only exists when the compile-time flag\n" |
"This procedure only exists when the compile-time flag\n" |
200 |
"@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.") |
"@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.") |
201 |
#define FUNC_NAME s_scm_set_debug_cell_accesses_x |
#define FUNC_NAME s_scm_set_debug_cell_accesses_x |
202 |
{ |
{ |
203 |
if (SCM_FALSEP (flag)) { |
if (SCM_FALSEP (flag)) |
204 |
scm_debug_cell_accesses_p = 0; |
{ |
205 |
} else if (SCM_EQ_P (flag, SCM_BOOL_T)) { |
scm_debug_cell_accesses_p = 0; |
206 |
debug_cells_gc_interval = 0; |
} |
207 |
scm_debug_cell_accesses_p = 1; |
else if (SCM_EQ_P (flag, SCM_BOOL_T)) |
208 |
} else if (SCM_INUMP (flag)) { |
{ |
209 |
long int f = SCM_INUM (flag); |
scm_debug_cells_gc_interval = 0; |
210 |
if (f <= 0) SCM_OUT_OF_RANGE (1, flag); |
scm_debug_cell_accesses_p = 1; |
211 |
debug_cells_gc_interval = f; |
scm_expensive_debug_cell_accesses_p = 0; |
212 |
scm_debug_cell_accesses_p = 1; |
} |
213 |
} else { |
else if (SCM_INUMP (flag)) |
214 |
SCM_WRONG_TYPE_ARG (1, flag); |
{ |
215 |
} |
long int f = SCM_INUM (flag); |
216 |
|
if (f <= 0) |
217 |
|
SCM_OUT_OF_RANGE (1, flag); |
218 |
|
scm_debug_cells_gc_interval = f; |
219 |
|
scm_debug_cell_accesses_p = 1; |
220 |
|
scm_expensive_debug_cell_accesses_p = 1; |
221 |
|
} |
222 |
|
else |
223 |
|
{ |
224 |
|
SCM_WRONG_TYPE_ARG (1, flag); |
225 |
|
} |
226 |
return SCM_UNSPECIFIED; |
return SCM_UNSPECIFIED; |
227 |
} |
} |
228 |
#undef FUNC_NAME |
#undef FUNC_NAME |
524 |
--scm_ints_disabled; |
--scm_ints_disabled; |
525 |
|
|
526 |
*free_cells = SCM_FREE_CELL_CDR (cell); |
*free_cells = SCM_FREE_CELL_CDR (cell); |
527 |
|
|
528 |
|
|
529 |
return cell; |
return cell; |
530 |
} |
} |
531 |
|
|
554 |
/* During the critical section, only the current thread may run. */ |
/* During the critical section, only the current thread may run. */ |
555 |
SCM_CRITICAL_SECTION_START; |
SCM_CRITICAL_SECTION_START; |
556 |
|
|
557 |
if (!scm_stack_base || scm_block_gc) |
if (!scm_root || !scm_stack_base || scm_block_gc) |
558 |
{ |
{ |
559 |
--scm_gc_running_p; |
--scm_gc_running_p; |
560 |
return; |
return; |
614 |
SCM_CRITICAL_SECTION_END; |
SCM_CRITICAL_SECTION_END; |
615 |
scm_c_hook_run (&scm_after_gc_c_hook, 0); |
scm_c_hook_run (&scm_after_gc_c_hook, 0); |
616 |
--scm_gc_running_p; |
--scm_gc_running_p; |
|
} |
|
|
|
|
|
|
|
|
|
|
617 |
|
|
618 |
|
/* |
619 |
|
For debugging purposes, you could do |
620 |
|
scm_i_sweep_all_segments("debug"), but then the remains of the |
621 |
|
cell aren't left to analyse. |
622 |
|
*/ |
623 |
|
} |
624 |
|
|
625 |
|
|
626 |
/* {GC Protection Helper Functions} |
/* {GC Protection Helper Functions} |
966 |
* after-gc-hook. |
* after-gc-hook. |
967 |
*/ |
*/ |
968 |
#if (SCM_DEBUG_CELL_ACCESSES == 1) |
#if (SCM_DEBUG_CELL_ACCESSES == 1) |
969 |
if (debug_cells_gc_interval == 0) |
if (scm_debug_cells_gc_interval == 0) |
970 |
scm_system_async_mark (gc_async); |
scm_system_async_mark (gc_async); |
971 |
#else |
#else |
972 |
scm_system_async_mark (gc_async); |
scm_system_async_mark (gc_async); |