comparison src/alloc.c @ 2971:fb22a4eb2694

[xemacs-hg @ 2005-10-04 16:47:10 by stephent] undo accidental commit
author stephent
date Tue, 04 Oct 2005 16:47:10 +0000
parents adda8fccb13d
children ec5f23ea6d2e
comparison
equal deleted inserted replaced
2970:adda8fccb13d 2971:fb22a4eb2694
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, 2003, 2004, 2005 Ben Wing. 4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 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
92 #endif 92 #endif
93 93
94 /* Number of bytes of consing done since the last gc */ 94 /* Number of bytes of consing done since the last gc */
95 static EMACS_INT consing_since_gc; 95 static EMACS_INT consing_since_gc;
96 EMACS_UINT total_consing; 96 EMACS_UINT total_consing;
97 EMACS_INT total_gc_usage;
98 int total_gc_usage_set;
99 97
100 int need_to_garbage_collect; 98 int need_to_garbage_collect;
101 int need_to_check_c_alloca; 99 int need_to_check_c_alloca;
102 int need_to_signal_post_gc; 100 int need_to_signal_post_gc;
103 int funcall_allocation_flag; 101 int funcall_allocation_flag;
5525 mark_object (bind->old_value); 5523 mark_object (bind->old_value);
5526 } 5524 }
5527 } 5525 }
5528 5526
5529 { 5527 {
5530 struct catchtag *c; 5528 struct catchtag *catch;
5531 for (c = catchlist; c; c = c->next) 5529 for (catch = catchlist; catch; catch = catch->next)
5532 { 5530 {
5533 mark_object (c->tag); 5531 mark_object (catch->tag);
5534 mark_object (c->val); 5532 mark_object (catch->val);
5535 mark_object (c->actual_tag); 5533 mark_object (catch->actual_tag);
5536 mark_object (c->backtrace); 5534 mark_object (catch->backtrace);
5537 } 5535 }
5538 } 5536 }
5539 5537
5540 { 5538 {
5541 struct backtrace *backlist; 5539 struct backtrace *backlist;
5769 } 5767 }
5770 #else /* not MC_ALLOC */ 5768 #else /* not MC_ALLOC */
5771 /* Debugging aids. */ 5769 /* Debugging aids. */
5772 5770
5773 static Lisp_Object 5771 static Lisp_Object
5774 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) 5772 gc_plist_hack (const Ascbyte *name, int value, Lisp_Object tail)
5775 { 5773 {
5776 /* C doesn't have local functions (or closures, or GC, or readable syntax, 5774 /* C doesn't have local functions (or closures, or GC, or readable syntax,
5777 or portable numeric datatypes, or bit-vectors, or characters, or 5775 or portable numeric datatypes, or bit-vectors, or characters, or
5778 arrays, or exceptions, or ...) */ 5776 arrays, or exceptions, or ...) */
5779 return cons3 (intern (name), make_int (value), tail); 5777 return cons3 (intern (name), make_int (value), tail);
5780 } 5778 }
5781 5779
5782 #define HACK_O_MATIC(type, name, pl) do { \ 5780 #define HACK_O_MATIC(type, name, pl) do { \
5783 EMACS_INT s = 0; \ 5781 int s = 0; \
5784 struct type##_block *x = current_##type##_block; \ 5782 struct type##_block *x = current_##type##_block; \
5785 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ 5783 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
5786 object_usage += s; \
5787 (pl) = gc_plist_hack ((name), s, (pl)); \ 5784 (pl) = gc_plist_hack ((name), s, (pl)); \
5788 } while (0) 5785 } while (0)
5789 5786
5790 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* 5787 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
5791 Reclaim storage for Lisp objects no longer needed. 5788 Reclaim storage for Lisp objects no longer needed.
5801 ()) 5798 ())
5802 { 5799 {
5803 Lisp_Object pl = Qnil; 5800 Lisp_Object pl = Qnil;
5804 int i; 5801 int i;
5805 int gc_count_vector_total_size = 0; 5802 int gc_count_vector_total_size = 0;
5806 EMACS_INT object_usage = 0;
5807
5808 garbage_collect_1 (); 5803 garbage_collect_1 ();
5809
5810 5804
5811 for (i = 0; i < lrecord_type_count; i++) 5805 for (i = 0; i < lrecord_type_count; i++)
5812 { 5806 {
5813 if (lcrecord_stats[i].bytes_in_use != 0 5807 if (lcrecord_stats[i].bytes_in_use != 0
5814 || lcrecord_stats[i].bytes_freed != 0 5808 || lcrecord_stats[i].bytes_freed != 0
5822 gc_count_vector_total_size = 5816 gc_count_vector_total_size =
5823 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed; 5817 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
5824 5818
5825 sprintf (buf, "%s-storage", name); 5819 sprintf (buf, "%s-storage", name);
5826 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); 5820 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
5827 object_usage += lcrecord_stats[i].bytes_in_use;
5828 /* Okay, simple pluralization check for `symbol-value-varalias' */ 5821 /* Okay, simple pluralization check for `symbol-value-varalias' */
5829 if (name[len-1] == 's') 5822 if (name[len-1] == 's')
5830 sprintf (buf, "%ses-freed", name); 5823 sprintf (buf, "%ses-freed", name);
5831 else 5824 else
5832 sprintf (buf, "%ss-freed", name); 5825 sprintf (buf, "%ss-freed", name);
5900 5893
5901 HACK_O_MATIC (cons, "cons-storage", pl); 5894 HACK_O_MATIC (cons, "cons-storage", pl);
5902 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl); 5895 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
5903 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl); 5896 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
5904 5897
5905 /* Record total usage for purposes of determining next GC */
5906 total_gc_usage = object_usage;
5907 total_gc_usage_set = 1;
5908
5909 /* The things we do for backwards-compatibility */ 5898 /* The things we do for backwards-compatibility */
5910 return 5899 return
5911 list6 (Fcons (make_int (gc_count_num_cons_in_use), 5900 list6 (Fcons (make_int (gc_count_num_cons_in_use),
5912 make_int (gc_count_num_cons_freelist)), 5901 make_int (gc_count_num_cons_freelist)),
5913 Fcons (make_int (gc_count_num_symbol_in_use), 5902 Fcons (make_int (gc_count_num_symbol_in_use),
5943 { 5932 {
5944 return make_int ((EMACS_INT) sbrk (0) / 1024); 5933 return make_int ((EMACS_INT) sbrk (0) / 1024);
5945 } 5934 }
5946 #endif 5935 #endif
5947 5936
5948 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /* 5937 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /*
5949 Return the total number of bytes used by the data segment in XEmacs. 5938 Return the total number of bytes used by the data segment in XEmacs.
5950 This may be helpful in debugging XEmacs's memory usage. 5939 This may be helpful in debugging XEmacs's memory usage.
5951 NOTE: This may or may not be accurate! It is hard to determine this
5952 value in a system-independent fashion.
5953 */ 5940 */
5954 ()) 5941 ())
5955 { 5942 {
5956 return make_int (total_data_usage ()); 5943 return make_int (total_data_usage ());
5957 }
5958
5959 DEFUN ("lisp-object-memory-usage", Flisp_object_memory_usage, 0, 0, 0, /*
5960 Return the total number of bytes used for object storage in XEmacs.
5961 This may be helpful in debugging XEmacs's memory usage.
5962 This value is only recomputed when garbage collection happens; thus, a
5963 better value of the real number of bytes used is
5964 (+ (lisp-object-memory-usage) (consing-since-gc))
5965 */
5966 ())
5967 {
5968 return make_int (total_gc_usage);
5969 } 5944 }
5970 5945
5971 void 5946 void
5972 recompute_funcall_allocation_flag (void) 5947 recompute_funcall_allocation_flag (void)
5973 { 5948 {
5984 if (always_gc) 5959 if (always_gc)
5985 need_to_garbage_collect = 1; 5960 need_to_garbage_collect = 1;
5986 else 5961 else
5987 need_to_garbage_collect = 5962 need_to_garbage_collect =
5988 (consing_since_gc > gc_cons_threshold 5963 (consing_since_gc > gc_cons_threshold
5964 #if 0 /* #### implement this better */
5989 && 5965 &&
5990 #if 0 /* #### implement this better */
5991 (100 * consing_since_gc) / total_data_usage () >= 5966 (100 * consing_since_gc) / total_data_usage () >=
5992 gc_cons_percentage 5967 gc_cons_percentage
5993 #else 5968 #endif /* 0 */
5994 (!total_gc_usage_set ||
5995 (100 * consing_since_gc) / total_gc_usage >=
5996 gc_cons_percentage)
5997 #endif
5998 ); 5969 );
5999 recompute_funcall_allocation_flag (); 5970 recompute_funcall_allocation_flag ();
6000 } 5971 }
6001 5972
6002 5973
6247 #if 1 6218 #if 1
6248 gc_cons_threshold = 500000; /* XEmacs change */ 6219 gc_cons_threshold = 500000; /* XEmacs change */
6249 #else 6220 #else
6250 gc_cons_threshold = 15000; /* debugging */ 6221 gc_cons_threshold = 15000; /* debugging */
6251 #endif 6222 #endif
6252 gc_cons_percentage = 40; /* #### what is optimal? */ 6223 gc_cons_percentage = 0; /* #### 20; Don't have an accurate measure of
6253 total_gc_usage_set = 0; 6224 memory usage on Windows; not verified on other
6225 systems */
6254 lrecord_uid_counter = 259; 6226 lrecord_uid_counter = 259;
6255 #ifndef MC_ALLOC 6227 #ifndef MC_ALLOC
6256 debug_string_purity = 0; 6228 debug_string_purity = 0;
6257 #endif /* not MC_ALLOC */ 6229 #endif /* not MC_ALLOC */
6258 6230
6380 #endif /* MC_ALLOC_TYPE_STATS */ 6352 #endif /* MC_ALLOC_TYPE_STATS */
6381 DEFSUBR (Fgarbage_collect); 6353 DEFSUBR (Fgarbage_collect);
6382 #if 0 6354 #if 0
6383 DEFSUBR (Fmemory_limit); 6355 DEFSUBR (Fmemory_limit);
6384 #endif 6356 #endif
6385 DEFSUBR (Ftotal_memory_usage); 6357 DEFSUBR (Fmemory_usage);
6386 DEFSUBR (Flisp_object_memory_usage);
6387 DEFSUBR (Fconsing_since_gc); 6358 DEFSUBR (Fconsing_since_gc);
6388 } 6359 }
6389 6360
6390 void 6361 void
6391 vars_of_alloc (void) 6362 vars_of_alloc (void)
6413 happen at *EVERY* call to `eval' or `funcall'. This is an extremely 6384 happen at *EVERY* call to `eval' or `funcall'. This is an extremely
6414 effective way to check GCPRO problems, but be warned that your XEmacs 6385 effective way to check GCPRO problems, but be warned that your XEmacs
6415 will be unusable! You almost certainly won't have the patience to wait 6386 will be unusable! You almost certainly won't have the patience to wait
6416 long enough to be able to set it back. 6387 long enough to be able to set it back.
6417 6388
6418 See also `consing-since-gc' and `gc-cons-percentage'. 6389 See also `consing-since-gc'.
6419 */ ); 6390 */ );
6420 6391
6421 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /* 6392 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
6422 *Percentage of memory allocated between garbage collections. 6393 *Percentage of memory allocated between garbage collections.
6423 6394
6424 Garbage collection will happen if this percentage of the total amount of 6395 Garbage collection will happen if this percentage of the total amount of
6425 memory used for data (see `lisp-object-memory-usage') has been allocated 6396 memory used for data has been allocated since the last garbage collection.
6426 since the last garbage collection. However, it will not happen if less 6397 However, it will not happen if less than `gc-cons-threshold' bytes have
6427 than `gc-cons-threshold' bytes have been allocated -- this sets an absolute 6398 been allocated -- this sets an absolute minimum in case very little data
6428 minimum in case very little data has been allocated or the percentage is 6399 has been allocated or the percentage is set very low. Set this to 0 to
6429 set very low. Set this to 0 to have garbage collection always happen after 6400 have garbage collection always happen after `gc-cons-threshold' bytes have
6430 `gc-cons-threshold' bytes have been allocated, regardless of current memory 6401 been allocated, regardless of current memory usage.
6431 usage. 6402
6432 6403 Garbage collection happens automatically when `eval' or `funcall' are
6433 See also `consing-since-gc' and `gc-cons-threshold'. 6404 called. (Note that `funcall' is called implicitly as part of evaluation.)
6405 By binding this temporarily to a large number, you can effectively
6406 prevent garbage collection during a part of the program.
6407
6408 See also `consing-since-gc'.
6434 */ ); 6409 */ );
6435 6410
6436 #ifdef DEBUG_XEMACS 6411 #ifdef DEBUG_XEMACS
6437 DEFVAR_INT ("debug-allocation", &debug_allocation /* 6412 DEFVAR_INT ("debug-allocation", &debug_allocation /*
6438 If non-zero, print out information to stderr about all objects allocated. 6413 If non-zero, print out information to stderr about all objects allocated.