Mercurial > hg > xemacs-beta
comparison src/alloc.c @ 1265:de6cf052e10b
[xemacs-hg @ 2003-02-07 00:49:41 by ben]
add KKCC tail-recursion
alloc.c: Implement tail-recursion in KKCC when the last-marked object is
a Lisp object, to avoid stack-overflow errors when marking long
lists. Factor out some duplicated error-checking into macros.
| author | ben |
|---|---|
| date | Fri, 07 Feb 2003 00:49:42 +0000 |
| parents | f0af455e89d9 |
| children | beb703ae34fd |
comparison
equal
deleted
inserted
replaced
| 1264:032904d02169 | 1265:de6cf052e10b |
|---|---|
| 1 /* Storage allocation and gc for XEmacs Lisp interpreter. | 1 /* Storage allocation and gc for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1998 Free Software Foundation, Inc. | 2 Copyright (C) 1985-1998 Free Software Foundation, Inc. |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | 3 Copyright (C) 1995 Sun Microsystems, Inc. |
| 4 Copyright (C) 1995, 1996, 2001, 2002 Ben Wing. | 4 Copyright (C) 1995, 1996, 2001, 2002, 2003 Ben Wing. |
| 5 | 5 |
| 6 This file is part of XEmacs. | 6 This file is part of XEmacs. |
| 7 | 7 |
| 8 XEmacs is free software; you can redistribute it and/or modify it | 8 XEmacs is free software; you can redistribute it and/or modify it |
| 9 under the terms of the GNU General Public License as published by the | 9 under the terms of the GNU General Public License as published by the |
| 3132 | 3132 |
| 3133 static void mark_struct_contents (const void *data, | 3133 static void mark_struct_contents (const void *data, |
| 3134 const struct sized_memory_description *sdesc, | 3134 const struct sized_memory_description *sdesc, |
| 3135 int count); | 3135 int count); |
| 3136 | 3136 |
| 3137 #define GC_CHECK_NOT_FREE(lheader) \ | |
| 3138 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ | |
| 3139 ! ((struct lcrecord_header *) lheader)->free) | |
| 3140 | |
| 3141 | |
| 3142 #ifdef ERROR_CHECK_GC | |
| 3143 #define KKCC_DO_CHECK_FREE(obj, allow_free) \ | |
| 3144 do \ | |
| 3145 { \ | |
| 3146 if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \ | |
| 3147 { \ | |
| 3148 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ | |
| 3149 GC_CHECK_NOT_FREE (lheader); \ | |
| 3150 } \ | |
| 3151 } while (0) | |
| 3152 #else | |
| 3153 #define KKCC_DO_CHECK_FREE(obj, allow_free) | |
| 3154 #endif | |
| 3137 | 3155 |
| 3138 #ifdef ERROR_CHECK_GC | 3156 #ifdef ERROR_CHECK_GC |
| 3139 void | 3157 void |
| 3140 mark_object_maybe_checking_free (Lisp_Object obj, int allow_free) | 3158 mark_object_maybe_checking_free (Lisp_Object obj, int allow_free) |
| 3141 { | 3159 { |
| 3142 | 3160 KKCC_DO_CHECK_FREE (obj, allow_free); |
| 3143 if (!allow_free && XTYPE (obj) == Lisp_Type_Record) | |
| 3144 { | |
| 3145 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 3146 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || | |
| 3147 ! ((struct lcrecord_header *) lheader)->free); | |
| 3148 } | |
| 3149 mark_object (obj); | 3161 mark_object (obj); |
| 3150 } | 3162 } |
| 3151 #else | 3163 #else |
| 3152 #define mark_object_maybe_checking_free(obj, allow_free) mark_object (obj) | 3164 #define mark_object_maybe_checking_free(obj, allow_free) mark_object (obj) |
| 3153 #endif /* ERROR_CHECK_GC */ | 3165 #endif /* ERROR_CHECK_GC */ |
| 3163 static const Lisp_Object *last_occurred_object = (Lisp_Object *) 0; | 3175 static const Lisp_Object *last_occurred_object = (Lisp_Object *) 0; |
| 3164 static int mark_last_occurred_object = 0; | 3176 static int mark_last_occurred_object = 0; |
| 3165 #ifdef ERROR_CHECK_GC | 3177 #ifdef ERROR_CHECK_GC |
| 3166 static int last_occurred_flags; | 3178 static int last_occurred_flags; |
| 3167 #endif | 3179 #endif |
| 3180 | |
| 3181 tail_recurse: | |
| 3168 | 3182 |
| 3169 for (pos = 0; desc[pos].type != XD_END; pos++) | 3183 for (pos = 0; desc[pos].type != XD_END; pos++) |
| 3170 { | 3184 { |
| 3171 const struct memory_description *desc1 = &desc[pos]; | 3185 const struct memory_description *desc1 = &desc[pos]; |
| 3172 const void *rdata = | 3186 const void *rdata = |
| 3271 } | 3285 } |
| 3272 } | 3286 } |
| 3273 | 3287 |
| 3274 if (mark_last_occurred_object) | 3288 if (mark_last_occurred_object) |
| 3275 { | 3289 { |
| 3290 Lisp_Object obj = *last_occurred_object; | |
| 3291 | |
| 3292 old_tail_recurse: | |
| 3276 /* NOTE: The second parameter isn't even evaluated | 3293 /* NOTE: The second parameter isn't even evaluated |
| 3277 non-ERROR_CHECK_GC, so it's OK for the variable not to exist. | 3294 non-ERROR_CHECK_GC, so it's OK for the variable not to exist. |
| 3278 */ | 3295 */ |
| 3279 mark_object_maybe_checking_free (*last_occurred_object, | 3296 KKCC_DO_CHECK_FREE |
| 3280 last_occurred_flags & | 3297 (obj, (last_occurred_flags & XD_FLAG_FREE_LISP_OBJECT) != 0); |
| 3281 XD_FLAG_FREE_LISP_OBJECT); | 3298 |
| 3299 if (XTYPE (obj) == Lisp_Type_Record) | |
| 3300 { | |
| 3301 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 3302 | |
| 3303 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 3304 | |
| 3305 /* All c_readonly objects have their mark bit set, | |
| 3306 so that we only need to check the mark bit here. */ | |
| 3307 if (! MARKED_RECORD_HEADER_P (lheader)) | |
| 3308 { | |
| 3309 MARK_RECORD_HEADER (lheader); | |
| 3310 | |
| 3311 { | |
| 3312 desc = LHEADER_IMPLEMENTATION (lheader)->description; | |
| 3313 if (desc) /* && !CONSP(obj))*/ /* KKCC cons special case */ | |
| 3314 { | |
| 3315 data = lheader; | |
| 3316 mark_last_occurred_object = 0; | |
| 3317 goto tail_recurse; | |
| 3318 } | |
| 3319 else | |
| 3320 { | |
| 3321 if (RECORD_MARKER (lheader)) | |
| 3322 { | |
| 3323 obj = RECORD_MARKER (lheader) (obj); | |
| 3324 if (!NILP (obj)) goto old_tail_recurse; | |
| 3325 } | |
| 3326 } | |
| 3327 } | |
| 3328 } | |
| 3329 } | |
| 3330 | |
| 3282 mark_last_occurred_object = 0; | 3331 mark_last_occurred_object = 0; |
| 3283 } | 3332 } |
| 3284 } | 3333 } |
| 3285 | 3334 |
| 3286 /* This function loops all elements of a struct pointer and calls | 3335 /* This function loops all elements of a struct pointer and calls |
| 3322 | 3371 |
| 3323 GC_CHECK_LHEADER_INVARIANTS (lheader); | 3372 GC_CHECK_LHEADER_INVARIANTS (lheader); |
| 3324 | 3373 |
| 3325 #ifndef USE_KKCC | 3374 #ifndef USE_KKCC |
| 3326 /* We handle this separately, above, so we can mark free objects */ | 3375 /* We handle this separately, above, so we can mark free objects */ |
| 3327 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || | 3376 GC_CHECK_NOT_FREE (lheader); |
| 3328 ! ((struct lcrecord_header *) lheader)->free); | |
| 3329 #endif /* not USE_KKCC */ | 3377 #endif /* not USE_KKCC */ |
| 3330 | |
| 3331 | 3378 |
| 3332 /* All c_readonly objects have their mark bit set, | 3379 /* All c_readonly objects have their mark bit set, |
| 3333 so that we only need to check the mark bit here. */ | 3380 so that we only need to check the mark bit here. */ |
| 3334 if (! MARKED_RECORD_HEADER_P (lheader)) | 3381 if (! MARKED_RECORD_HEADER_P (lheader)) |
| 3335 { | 3382 { |
| 3336 MARK_RECORD_HEADER (lheader); | 3383 MARK_RECORD_HEADER (lheader); |
| 3337 | 3384 |
| 3338 { | 3385 { |
| 3339 #ifdef USE_KKCC | 3386 #ifdef USE_KKCC |
| 3340 const struct lrecord_implementation *imp; | |
| 3341 const struct memory_description *desc; | 3387 const struct memory_description *desc; |
| 3342 | 3388 desc = LHEADER_IMPLEMENTATION (lheader)->description; |
| 3343 imp = LHEADER_IMPLEMENTATION (lheader); | |
| 3344 desc = imp->description; | |
| 3345 | |
| 3346 if (desc) /* && !CONSP(obj))*/ /* KKCC cons special case */ | 3389 if (desc) /* && !CONSP(obj))*/ /* KKCC cons special case */ |
| 3347 { | 3390 mark_with_description (lheader, desc); |
| 3348 mark_with_description (lheader, desc); | |
| 3349 } | |
| 3350 else | 3391 else |
| 3351 #endif /* USE_KKCC */ | 3392 #endif /* USE_KKCC */ |
| 3352 { | 3393 { |
| 3353 if (RECORD_MARKER (lheader)) | 3394 if (RECORD_MARKER (lheader)) |
| 3354 { | 3395 { |