Mercurial > hg > xemacs-beta
annotate src/alloc.c @ 5167:e374ea766cc1
clean up, rearrange allocation statistics code
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-21 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (assert_proper_sizing):
* alloc.c (c_readonly):
* alloc.c (malloced_storage_size):
* alloc.c (fixed_type_block_overhead):
* alloc.c (lisp_object_storage_size):
* alloc.c (inc_lrecord_stats):
* alloc.c (dec_lrecord_stats):
* alloc.c (pluralize_word):
* alloc.c (object_memory_usage_stats):
* alloc.c (Fobject_memory_usage):
* alloc.c (compute_memusage_stats_length):
* alloc.c (disksave_object_finalization_1):
* alloc.c (Fgarbage_collect):
* mc-alloc.c:
* mc-alloc.c (mc_alloced_storage_size):
* mc-alloc.h:
No functionality change here. Collect the allocations-statistics
code that was scattered throughout alloc.c into one place. Add
remaining section headings so that all sections have headings
clearly identifying the start of the section and its purpose.
Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS;
this fixes build problems and is related to the export of
lisp_object_storage_size() and malloced_storage_size() when
non-MEMORY_USAGE_STATS in the previous change set.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Sun, 21 Mar 2010 04:41:49 -0500 |
parents | ab9ee10a53e4 |
children | 5ddbab03b0e6 |
rev | line source |
---|---|
428 | 1 /* Storage allocation and gc for XEmacs Lisp interpreter. |
2 Copyright (C) 1985-1998 Free Software Foundation, Inc. | |
3 Copyright (C) 1995 Sun Microsystems, Inc. | |
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2010 Ben Wing. |
428 | 5 |
6 This file is part of XEmacs. | |
7 | |
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 | |
10 Free Software Foundation; either version 2, or (at your option) any | |
11 later version. | |
12 | |
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 for more details. | |
17 | |
18 You should have received a copy of the GNU General Public License | |
19 along with XEmacs; see the file COPYING. If not, write to | |
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 Boston, MA 02111-1307, USA. */ | |
22 | |
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from | |
24 FSF. */ | |
25 | |
26 /* Authorship: | |
27 | |
28 FSF: Original version; a long time ago. | |
29 Mly: Significantly rewritten to use new 3-bit tags and | |
30 nicely abstracted object definitions, for 19.8. | |
31 JWZ: Improved code to keep track of purespace usage and | |
32 issue nice purespace and GC stats. | |
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking | |
34 and various changes for Mule, for 19.12. | |
35 Added bit vectors for 19.13. | |
36 Added lcrecord lists for 19.14. | |
37 slb: Lots of work on the purification and dump time code. | |
38 Synched Doug Lea malloc support from Emacs 20.2. | |
442 | 39 og: Killed the purespace. Portable dumper (moved to dumper.c) |
428 | 40 */ |
41 | |
42 #include <config.h> | |
43 #include "lisp.h" | |
44 | |
45 #include "backtrace.h" | |
46 #include "buffer.h" | |
47 #include "bytecode.h" | |
48 #include "chartab.h" | |
49 #include "device.h" | |
50 #include "elhash.h" | |
51 #include "events.h" | |
872 | 52 #include "extents-impl.h" |
1204 | 53 #include "file-coding.h" |
872 | 54 #include "frame-impl.h" |
3092 | 55 #include "gc.h" |
428 | 56 #include "glyphs.h" |
57 #include "opaque.h" | |
1204 | 58 #include "lstream.h" |
872 | 59 #include "process.h" |
1292 | 60 #include "profile.h" |
428 | 61 #include "redisplay.h" |
62 #include "specifier.h" | |
63 #include "sysfile.h" | |
442 | 64 #include "sysdep.h" |
428 | 65 #include "window.h" |
3092 | 66 #ifdef NEW_GC |
67 #include "vdb.h" | |
68 #endif /* NEW_GC */ | |
428 | 69 #include "console-stream.h" |
70 | |
71 #ifdef DOUG_LEA_MALLOC | |
72 #include <malloc.h> | |
73 #endif | |
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
74 #ifdef USE_VALGRIND |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
75 #include <valgrind/memcheck.h> |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
76 #endif |
428 | 77 |
78 EXFUN (Fgarbage_collect, 0); | |
79 | |
80 #if 0 /* this is _way_ too slow to be part of the standard debug options */ | |
81 #if defined(DEBUG_XEMACS) && defined(MULE) | |
82 #define VERIFY_STRING_CHARS_INTEGRITY | |
83 #endif | |
84 #endif | |
85 | |
86 /* Define this to use malloc/free with no freelist for all datatypes, | |
87 the hope being that some debugging tools may help detect | |
88 freed memory references */ | |
89 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ | |
90 #include <dmalloc.h> | |
91 #define ALLOC_NO_POOLS | |
92 #endif | |
93 | |
94 #ifdef DEBUG_XEMACS | |
458 | 95 static Fixnum debug_allocation; |
96 static Fixnum debug_allocation_backtrace_length; | |
428 | 97 #endif |
98 | |
851 | 99 int need_to_check_c_alloca; |
887 | 100 int need_to_signal_post_gc; |
851 | 101 int funcall_allocation_flag; |
102 Bytecount __temp_alloca_size__; | |
103 Bytecount funcall_alloca_count; | |
814 | 104 |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
105 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
106 Additional ones may be defined by a module (none yet). We leave some |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
107 room in `lrecord_implementations_table' for such new lisp object types. */ |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
108 struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
109 int lrecord_type_count = lrecord_type_last_built_in_type; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
110 |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
111 /* This is just for use by the printer, to allow things to print uniquely. |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
112 We have a separate UID space for each object. (Important because the |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
113 UID is only 20 bits in old-GC, and 22 in NEW_GC.) */ |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
114 int lrecord_uid_counter[countof (lrecord_implementations_table)]; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
115 |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
116 #ifndef USE_KKCC |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
117 /* Object marker functions are in the lrecord_implementation structure. |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
118 But copying them to a parallel array is much more cache-friendly. |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
119 This hack speeds up (garbage-collect) by about 5%. */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
120 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
121 #endif /* not USE_KKCC */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
122 |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
123 struct gcpro *gcprolist; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
124 |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
125 /* Non-zero means we're in the process of doing the dump */ |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
126 int purify_flag; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
127 |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
128 /* Non-zero means we're pdumping out or in */ |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
129 #ifdef PDUMP |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
130 int in_pdump; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
131 #endif |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
132 |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
133 #ifdef ERROR_CHECK_TYPES |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
134 |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
135 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
136 |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
137 #endif |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
138 |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
139 #ifdef MEMORY_USAGE_STATS |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
140 Lisp_Object Qobject_actually_requested, Qobject_malloc_overhead; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
141 Lisp_Object Qother_memory_actually_requested, Qother_memory_malloc_overhead; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
142 Lisp_Object Qother_memory_dynarr_overhead, Qother_memory_gap_overhead; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
143 #endif /* MEMORY_USAGE_STATS */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
144 |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
145 #ifndef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
146 static int gc_count_num_short_string_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
147 static Bytecount gc_count_string_total_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
148 static Bytecount gc_count_short_string_total_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
149 static Bytecount gc_count_long_string_storage_including_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
150 #endif /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
151 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
152 /* static int gc_count_total_records_used, gc_count_records_total_size; */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
153 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
154 /* stats on objects in use */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
155 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
156 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
157 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
158 static struct |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
159 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
160 int instances_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
161 int bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
162 int bytes_in_use_including_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
163 } lrecord_stats [countof (lrecord_implementations_table)]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
164 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
165 #else /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
166 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
167 static struct |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
168 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
169 Elemcount instances_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
170 Bytecount bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
171 Bytecount bytes_in_use_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
172 Elemcount instances_freed; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
173 Bytecount bytes_freed; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
174 Bytecount bytes_freed_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
175 Elemcount instances_on_free_list; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
176 Bytecount bytes_on_free_list; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
177 Bytecount bytes_on_free_list_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
178 #ifdef MEMORY_USAGE_STATS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
179 Bytecount nonlisp_bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
180 struct generic_usage_stats stats; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
181 #endif |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
182 } lrecord_stats [countof (lrecord_implementations_table)]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
183 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
184 #endif /* (not) NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
185 |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
186 /* Very cheesy ways of figuring out how much memory is being used for |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
187 data. #### Need better (system-dependent) ways. */ |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
188 void *minimum_address_seen; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
189 void *maximum_address_seen; |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
190 |
428 | 191 |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
192 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
193 /* Low-level allocation */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
194 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
195 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
196 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
197 recompute_funcall_allocation_flag (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
198 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
199 funcall_allocation_flag = |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
200 need_to_garbage_collect || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
201 need_to_check_c_alloca || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
202 need_to_signal_post_gc; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
203 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
204 |
428 | 205 /* Maximum amount of C stack to save when a GC happens. */ |
206 | |
207 #ifndef MAX_SAVE_STACK | |
208 #define MAX_SAVE_STACK 0 /* 16000 */ | |
209 #endif | |
210 | |
211 /* Non-zero means ignore malloc warnings. Set during initialization. */ | |
212 int ignore_malloc_warnings; | |
213 | |
214 | |
3263 | 215 #ifndef NEW_GC |
3092 | 216 void *breathing_space; |
428 | 217 |
218 void | |
219 release_breathing_space (void) | |
220 { | |
221 if (breathing_space) | |
222 { | |
223 void *tmp = breathing_space; | |
224 breathing_space = 0; | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
225 xfree (tmp); |
428 | 226 } |
227 } | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
228 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
229 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
230 /* If we released our reserve (due to running out of memory), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
231 and we have a fair amount free once again, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
232 try to set aside another reserve in case we run out once more. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
233 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
234 This is called when a relocatable block is freed in ralloc.c. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
235 void refill_memory_reserve (void); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
236 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
237 refill_memory_reserve (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
238 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
239 if (breathing_space == 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
240 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
241 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
242 #endif /* !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
243 |
3263 | 244 #endif /* not NEW_GC */ |
428 | 245 |
801 | 246 static void |
247 set_alloc_mins_and_maxes (void *val, Bytecount size) | |
248 { | |
249 if (!val) | |
250 return; | |
251 if ((char *) val + size > (char *) maximum_address_seen) | |
252 maximum_address_seen = (char *) val + size; | |
253 if (!minimum_address_seen) | |
254 minimum_address_seen = | |
255 #if SIZEOF_VOID_P == 8 | |
256 (void *) 0xFFFFFFFFFFFFFFFF; | |
257 #else | |
258 (void *) 0xFFFFFFFF; | |
259 #endif | |
260 if ((char *) val < (char *) minimum_address_seen) | |
261 minimum_address_seen = (char *) val; | |
262 } | |
263 | |
1315 | 264 #ifdef ERROR_CHECK_MALLOC |
3176 | 265 static int in_malloc; |
1333 | 266 extern int regex_malloc_disallowed; |
2367 | 267 |
268 #define MALLOC_BEGIN() \ | |
269 do \ | |
270 { \ | |
3176 | 271 assert (!in_malloc); \ |
2367 | 272 assert (!regex_malloc_disallowed); \ |
273 in_malloc = 1; \ | |
274 } \ | |
275 while (0) | |
276 | |
3263 | 277 #ifdef NEW_GC |
2720 | 278 #define FREE_OR_REALLOC_BEGIN(block) \ |
279 do \ | |
280 { \ | |
281 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
282 error until much later on for many system mallocs, such as \ | |
283 the one that comes with Solaris 2.3. FMH!! */ \ | |
4938
299dce99bdad
(for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents:
4934
diff
changeset
|
284 assert (block != (void *) DEADBEEF_CONSTANT); \ |
2720 | 285 MALLOC_BEGIN (); \ |
286 } \ | |
287 while (0) | |
3263 | 288 #else /* not NEW_GC */ |
2367 | 289 #define FREE_OR_REALLOC_BEGIN(block) \ |
290 do \ | |
291 { \ | |
292 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
293 error until much later on for many system mallocs, such as \ | |
294 the one that comes with Solaris 2.3. FMH!! */ \ | |
4938
299dce99bdad
(for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents:
4934
diff
changeset
|
295 assert (block != (void *) DEADBEEF_CONSTANT); \ |
2367 | 296 /* You cannot free something within dumped space, because there is \ |
297 no longer any sort of malloc structure associated with the block. \ | |
298 If you are tripping this, you may need to conditionalize on \ | |
299 DUMPEDP. */ \ | |
300 assert (!DUMPEDP (block)); \ | |
301 MALLOC_BEGIN (); \ | |
302 } \ | |
303 while (0) | |
3263 | 304 #endif /* not NEW_GC */ |
2367 | 305 |
306 #define MALLOC_END() \ | |
307 do \ | |
308 { \ | |
309 in_malloc = 0; \ | |
310 } \ | |
311 while (0) | |
312 | |
313 #else /* ERROR_CHECK_MALLOC */ | |
314 | |
2658 | 315 #define MALLOC_BEGIN() |
2367 | 316 #define FREE_OR_REALLOC_BEGIN(block) |
317 #define MALLOC_END() | |
318 | |
319 #endif /* ERROR_CHECK_MALLOC */ | |
320 | |
321 static void | |
322 malloc_after (void *val, Bytecount size) | |
323 { | |
324 if (!val && size != 0) | |
325 memory_full (); | |
326 set_alloc_mins_and_maxes (val, size); | |
327 } | |
328 | |
3305 | 329 /* malloc calls this if it finds we are near exhausting storage */ |
330 void | |
331 malloc_warning (const char *str) | |
332 { | |
333 if (ignore_malloc_warnings) | |
334 return; | |
335 | |
336 /* Remove the malloc lock here, because warn_when_safe may allocate | |
337 again. It is safe to remove the malloc lock here, because malloc | |
338 is already finished (malloc_warning is called via | |
339 after_morecore_hook -> check_memory_limits -> save_warn_fun -> | |
340 malloc_warning). */ | |
341 MALLOC_END (); | |
342 | |
343 warn_when_safe | |
344 (Qmemory, Qemergency, | |
345 "%s\n" | |
346 "Killing some buffers may delay running out of memory.\n" | |
347 "However, certainly by the time you receive the 95%% warning,\n" | |
348 "you should clean up, kill this Emacs, and start a new one.", | |
349 str); | |
350 } | |
351 | |
352 /* Called if malloc returns zero */ | |
353 DOESNT_RETURN | |
354 memory_full (void) | |
355 { | |
356 /* Force a GC next time eval is called. | |
357 It's better to loop garbage-collecting (we might reclaim enough | |
358 to win) than to loop beeping and barfing "Memory exhausted" | |
359 */ | |
360 consing_since_gc = gc_cons_threshold + 1; | |
361 recompute_need_to_garbage_collect (); | |
362 #ifdef NEW_GC | |
363 /* Put mc-alloc into memory shortage mode. This may keep XEmacs | |
364 alive until the garbage collector can free enough memory to get | |
365 us out of the memory exhaustion. If already in memory shortage | |
366 mode, we are in a loop and hopelessly lost. */ | |
367 if (memory_shortage) | |
368 { | |
369 fprintf (stderr, "Memory full, cannot recover.\n"); | |
370 ABORT (); | |
371 } | |
372 fprintf (stderr, | |
373 "Memory full, try to recover.\n" | |
374 "You should clean up, kill this Emacs, and start a new one.\n"); | |
375 memory_shortage++; | |
376 #else /* not NEW_GC */ | |
377 release_breathing_space (); | |
378 #endif /* not NEW_GC */ | |
379 | |
380 /* Flush some histories which might conceivably contain garbalogical | |
381 inhibitors. */ | |
382 if (!NILP (Fboundp (Qvalues))) | |
383 Fset (Qvalues, Qnil); | |
384 Vcommand_history = Qnil; | |
385 | |
386 out_of_memory ("Memory exhausted", Qunbound); | |
387 } | |
388 | |
2367 | 389 /* like malloc, calloc, realloc, free but: |
390 | |
391 -- check for no memory left | |
392 -- set internal mins and maxes | |
393 -- with error-checking on, check for reentrancy, invalid freeing, etc. | |
394 */ | |
1292 | 395 |
428 | 396 #undef xmalloc |
397 void * | |
665 | 398 xmalloc (Bytecount size) |
428 | 399 { |
1292 | 400 void *val; |
2367 | 401 MALLOC_BEGIN (); |
1292 | 402 val = malloc (size); |
2367 | 403 MALLOC_END (); |
404 malloc_after (val, size); | |
428 | 405 return val; |
406 } | |
407 | |
408 #undef xcalloc | |
409 static void * | |
665 | 410 xcalloc (Elemcount nelem, Bytecount elsize) |
428 | 411 { |
1292 | 412 void *val; |
2367 | 413 MALLOC_BEGIN (); |
1292 | 414 val= calloc (nelem, elsize); |
2367 | 415 MALLOC_END (); |
416 malloc_after (val, nelem * elsize); | |
428 | 417 return val; |
418 } | |
419 | |
420 void * | |
665 | 421 xmalloc_and_zero (Bytecount size) |
428 | 422 { |
423 return xcalloc (size, sizeof (char)); | |
424 } | |
425 | |
426 #undef xrealloc | |
427 void * | |
665 | 428 xrealloc (void *block, Bytecount size) |
428 | 429 { |
2367 | 430 FREE_OR_REALLOC_BEGIN (block); |
551 | 431 block = realloc (block, size); |
2367 | 432 MALLOC_END (); |
433 malloc_after (block, size); | |
551 | 434 return block; |
428 | 435 } |
436 | |
437 void | |
438 xfree_1 (void *block) | |
439 { | |
440 #ifdef ERROR_CHECK_MALLOC | |
441 assert (block); | |
442 #endif /* ERROR_CHECK_MALLOC */ | |
2367 | 443 FREE_OR_REALLOC_BEGIN (block); |
428 | 444 free (block); |
2367 | 445 MALLOC_END (); |
428 | 446 } |
447 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
448 void |
665 | 449 deadbeef_memory (void *ptr, Bytecount size) |
428 | 450 { |
826 | 451 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; |
665 | 452 Bytecount beefs = size >> 2; |
428 | 453 |
454 /* In practice, size will always be a multiple of four. */ | |
455 while (beefs--) | |
1204 | 456 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ |
428 | 457 } |
458 | |
459 #undef xstrdup | |
460 char * | |
442 | 461 xstrdup (const char *str) |
428 | 462 { |
463 int len = strlen (str) + 1; /* for stupid terminating 0 */ | |
464 void *val = xmalloc (len); | |
771 | 465 |
428 | 466 if (val == 0) return 0; |
467 return (char *) memcpy (val, str, len); | |
468 } | |
469 | |
470 #ifdef NEED_STRDUP | |
471 char * | |
442 | 472 strdup (const char *s) |
428 | 473 { |
474 return xstrdup (s); | |
475 } | |
476 #endif /* NEED_STRDUP */ | |
477 | |
478 | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
479 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
480 /* Lisp object allocation */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
481 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
482 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
483 /* Determine now whether we need to garbage collect or not, to make |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
484 Ffuncall() faster */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
485 #define INCREMENT_CONS_COUNTER_1(size) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
486 do \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
487 { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
488 consing_since_gc += (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
489 total_consing += (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
490 if (profiling_active) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
491 profile_record_consing (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
492 recompute_need_to_garbage_collect (); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
493 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
494 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
495 #define debug_allocation_backtrace() \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
496 do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
497 if (debug_allocation_backtrace_length > 0) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
498 debug_short_backtrace (debug_allocation_backtrace_length); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
499 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
500 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
501 #ifdef DEBUG_XEMACS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
502 #define INCREMENT_CONS_COUNTER(foosize, type) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
503 do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
504 if (debug_allocation) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
505 { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
506 stderr_out ("allocating %s (size %ld)\n", type, \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
507 (long) foosize); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
508 debug_allocation_backtrace (); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
509 } \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
510 INCREMENT_CONS_COUNTER_1 (foosize); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
511 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
512 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
513 do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
514 if (debug_allocation > 1) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
515 { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
516 stderr_out ("allocating noseeum %s (size %ld)\n", type, \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
517 (long) foosize); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
518 debug_allocation_backtrace (); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
519 } \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
520 INCREMENT_CONS_COUNTER_1 (foosize); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
521 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
522 #else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
523 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
524 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
525 INCREMENT_CONS_COUNTER_1 (size) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
526 #endif |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
527 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
528 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
529 /* [[ The call to recompute_need_to_garbage_collect is moved to |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
530 free_normal_lisp_object, since DECREMENT_CONS_COUNTER is extensively called |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
531 during sweep and recomputing need_to_garbage_collect all the time |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
532 is not needed. ]] -- not accurate! */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
533 #define DECREMENT_CONS_COUNTER(size) do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
534 consing_since_gc -= (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
535 total_consing -= (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
536 if (profiling_active) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
537 profile_record_unconsing (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
538 if (consing_since_gc < 0) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
539 consing_since_gc = 0; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
540 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
541 #else /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
542 #define DECREMENT_CONS_COUNTER(size) do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
543 consing_since_gc -= (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
544 total_consing -= (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
545 if (profiling_active) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
546 profile_record_unconsing (size); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
547 if (consing_since_gc < 0) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
548 consing_since_gc = 0; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
549 recompute_need_to_garbage_collect (); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
550 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
551 #endif /*not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
552 |
3263 | 553 #ifndef NEW_GC |
428 | 554 static void * |
665 | 555 allocate_lisp_storage (Bytecount size) |
428 | 556 { |
793 | 557 void *val = xmalloc (size); |
558 /* We don't increment the cons counter anymore. Calling functions do | |
559 that now because we have two different kinds of cons counters -- one | |
560 for normal objects, and one for no-see-um conses (and possibly others | |
561 similar) where the conses are used totally internally, never escape, | |
562 and are created and then freed and shouldn't logically increment the | |
563 cons counting. #### (Or perhaps, we should decrement it when an object | |
564 get freed?) */ | |
565 | |
566 /* But we do now (as of 3-27-02) go and zero out the memory. This is a | |
567 good thing, as it will guarantee we won't get any intermittent bugs | |
1204 | 568 coming from an uninitiated field. The speed loss is unnoticeable, |
569 esp. as the objects are not large -- large stuff like buffer text and | |
570 redisplay structures are allocated separately. */ | |
793 | 571 memset (val, 0, size); |
851 | 572 |
573 if (need_to_check_c_alloca) | |
574 xemacs_c_alloca (0); | |
575 | |
793 | 576 return val; |
428 | 577 } |
3263 | 578 #endif /* not NEW_GC */ |
579 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
580 #define assert_proper_sizing(size) \ |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
581 type_checking_assert \ |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
582 (implementation->static_size == 0 ? \ |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
583 implementation->size_in_bytes_method != NULL : \ |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
584 implementation->size_in_bytes_method == NULL && \ |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
585 implementation->static_size == size) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
586 |
3263 | 587 #ifndef NEW_GC |
442 | 588 /* lcrecords are chained together through their "next" field. |
589 After doing the mark phase, GC will walk this linked list | |
590 and free any lcrecord which hasn't been marked. */ | |
3024 | 591 static struct old_lcrecord_header *all_lcrecords; |
3263 | 592 #endif /* not NEW_GC */ |
593 | |
594 #ifdef NEW_GC | |
2720 | 595 /* The basic lrecord allocation functions. See lrecord.h for details. */ |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
596 static Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
597 alloc_sized_lrecord_1 (Bytecount size, |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
598 const struct lrecord_implementation *implementation, |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
599 int noseeum) |
2720 | 600 { |
601 struct lrecord_header *lheader; | |
602 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
603 assert_proper_sizing (size); |
2720 | 604 |
605 lheader = (struct lrecord_header *) mc_alloc (size); | |
606 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
607 set_lheader_implementation (lheader, implementation); | |
2994 | 608 #ifdef ALLOC_TYPE_STATS |
2720 | 609 inc_lrecord_stats (size, lheader); |
2994 | 610 #endif /* ALLOC_TYPE_STATS */ |
3263 | 611 if (implementation->finalizer) |
612 add_finalizable_obj (wrap_pointer_1 (lheader)); | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
613 if (noseeum) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
614 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
615 else |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
616 INCREMENT_CONS_COUNTER (size, implementation->name); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
617 return wrap_pointer_1 (lheader); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
618 } |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
619 |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
620 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
621 alloc_sized_lrecord (Bytecount size, |
3092 | 622 const struct lrecord_implementation *implementation) |
623 { | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
624 return alloc_sized_lrecord_1 (size, implementation, 0); |
2720 | 625 } |
626 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
627 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
628 noseeum_alloc_sized_lrecord (Bytecount size, |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
629 const struct lrecord_implementation * |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
630 implementation) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
631 { |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
632 return alloc_sized_lrecord_1 (size, implementation, 1); |
2720 | 633 } |
634 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
635 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
636 alloc_lrecord (const struct lrecord_implementation *implementation) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
637 { |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
638 type_checking_assert (implementation->static_size > 0); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
639 return alloc_sized_lrecord (implementation->static_size, implementation); |
2720 | 640 } |
641 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
642 Lisp_Object |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
643 noseeum_alloc_lrecord (const struct lrecord_implementation *implementation) |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
644 { |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
645 type_checking_assert (implementation->static_size > 0); |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
646 return noseeum_alloc_sized_lrecord (implementation->static_size, implementation); |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
647 } |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
648 |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
649 Lisp_Object |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
650 alloc_sized_lrecord_array (Bytecount size, int elemcount, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
651 const struct lrecord_implementation *implementation) |
3092 | 652 { |
653 struct lrecord_header *lheader; | |
654 Rawbyte *start, *stop; | |
655 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
656 assert_proper_sizing (size); |
3092 | 657 |
658 lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount); | |
659 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
660 |
3092 | 661 for (start = (Rawbyte *) lheader, |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
662 /* #### FIXME: why is this -1 present? */ |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
663 stop = ((Rawbyte *) lheader) + (size * elemcount -1); |
3092 | 664 start < stop; start += size) |
665 { | |
666 struct lrecord_header *lh = (struct lrecord_header *) start; | |
667 set_lheader_implementation (lh, implementation); | |
668 #ifdef ALLOC_TYPE_STATS | |
669 inc_lrecord_stats (size, lh); | |
670 #endif /* not ALLOC_TYPE_STATS */ | |
3263 | 671 if (implementation->finalizer) |
672 add_finalizable_obj (wrap_pointer_1 (lh)); | |
3092 | 673 } |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
674 |
3092 | 675 INCREMENT_CONS_COUNTER (size * elemcount, implementation->name); |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
676 return wrap_pointer_1 (lheader); |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
677 } |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
678 |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
679 Lisp_Object |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
680 alloc_lrecord_array (int elemcount, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
681 const struct lrecord_implementation *implementation) |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
682 { |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
683 type_checking_assert (implementation->static_size > 0); |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
684 return alloc_sized_lrecord_array (implementation->static_size, elemcount, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
685 implementation); |
3092 | 686 } |
687 | |
3263 | 688 #else /* not NEW_GC */ |
428 | 689 |
1204 | 690 /* The most basic of the lcrecord allocation functions. Not usually called |
691 directly. Allocates an lrecord not managed by any lcrecord-list, of a | |
692 specified size. See lrecord.h. */ | |
693 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
694 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
695 old_alloc_sized_lcrecord (Bytecount size, |
3024 | 696 const struct lrecord_implementation *implementation) |
697 { | |
698 struct old_lcrecord_header *lcheader; | |
428 | 699 |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
700 assert_proper_sizing (size); |
442 | 701 type_checking_assert |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
702 (!implementation->frob_block_p |
442 | 703 && |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
704 !(implementation->hash == NULL && implementation->equal != NULL)); |
428 | 705 |
3024 | 706 lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size); |
442 | 707 set_lheader_implementation (&lcheader->lheader, implementation); |
428 | 708 lcheader->next = all_lcrecords; |
709 all_lcrecords = lcheader; | |
710 INCREMENT_CONS_COUNTER (size, implementation->name); | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
711 return wrap_pointer_1 (lcheader); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
712 } |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
713 |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
714 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
715 old_alloc_lcrecord (const struct lrecord_implementation *implementation) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
716 { |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
717 type_checking_assert (implementation->static_size > 0); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
718 return old_alloc_sized_lcrecord (implementation->static_size, |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
719 implementation); |
428 | 720 } |
721 | |
722 #if 0 /* Presently unused */ | |
723 /* Very, very poor man's EGC? | |
724 * This may be slow and thrash pages all over the place. | |
725 * Only call it if you really feel you must (and if the | |
726 * lrecord was fairly recently allocated). | |
727 * Otherwise, just let the GC do its job -- that's what it's there for | |
728 */ | |
729 void | |
3024 | 730 very_old_free_lcrecord (struct old_lcrecord_header *lcrecord) |
428 | 731 { |
732 if (all_lcrecords == lcrecord) | |
733 { | |
734 all_lcrecords = lcrecord->next; | |
735 } | |
736 else | |
737 { | |
3024 | 738 struct old_lcrecord_header *header = all_lcrecords; |
428 | 739 for (;;) |
740 { | |
3024 | 741 struct old_lcrecord_header *next = header->next; |
428 | 742 if (next == lcrecord) |
743 { | |
744 header->next = lrecord->next; | |
745 break; | |
746 } | |
747 else if (next == 0) | |
2500 | 748 ABORT (); |
428 | 749 else |
750 header = next; | |
751 } | |
752 } | |
753 if (lrecord->implementation->finalizer) | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
754 lrecord->implementation->finalizer (wrap_pointer_1 (lrecord)); |
428 | 755 xfree (lrecord); |
756 return; | |
757 } | |
758 #endif /* Unused */ | |
3263 | 759 #endif /* not NEW_GC */ |
428 | 760 |
1204 | 761 /* Bitwise copy all parts of a Lisp object other than the header */ |
762 | |
763 void | |
764 copy_lisp_object (Lisp_Object dst, Lisp_Object src) | |
765 { | |
766 const struct lrecord_implementation *imp = | |
767 XRECORD_LHEADER_IMPLEMENTATION (src); | |
768 Bytecount size = lisp_object_size (src); | |
769 | |
770 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst)); | |
771 assert (size == lisp_object_size (dst)); | |
772 | |
3263 | 773 #ifdef NEW_GC |
2720 | 774 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), |
775 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
776 size - sizeof (struct lrecord_header)); | |
3263 | 777 #else /* not NEW_GC */ |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
778 if (imp->frob_block_p) |
1204 | 779 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), |
780 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
781 size - sizeof (struct lrecord_header)); | |
782 else | |
3024 | 783 memcpy ((char *) XRECORD_LHEADER (dst) + |
784 sizeof (struct old_lcrecord_header), | |
785 (char *) XRECORD_LHEADER (src) + | |
786 sizeof (struct old_lcrecord_header), | |
787 size - sizeof (struct old_lcrecord_header)); | |
3263 | 788 #endif /* not NEW_GC */ |
1204 | 789 } |
790 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
791 /* Zero out all parts of a Lisp object other than the header, for a |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
792 variable-sized object. The size needs to be given explicitly because |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
793 at the time this is called, the contents of the object may not be |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
794 defined, or may not be set up in such a way that we can reliably |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
795 retrieve the size, since it may depend on settings inside of the object. */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
796 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
797 void |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
798 zero_sized_lisp_object (Lisp_Object obj, Bytecount size) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
799 { |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
800 #ifndef NEW_GC |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
801 const struct lrecord_implementation *imp = |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
802 XRECORD_LHEADER_IMPLEMENTATION (obj); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
803 #endif /* not NEW_GC */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
804 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
805 #ifdef NEW_GC |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
806 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
807 size - sizeof (struct lrecord_header)); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
808 #else /* not NEW_GC */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
809 if (imp->frob_block_p) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
810 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
811 size - sizeof (struct lrecord_header)); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
812 else |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
813 memset ((char *) XRECORD_LHEADER (obj) + |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
814 sizeof (struct old_lcrecord_header), 0, |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
815 size - sizeof (struct old_lcrecord_header)); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
816 #endif /* not NEW_GC */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
817 } |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
818 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
819 /* Zero out all parts of a Lisp object other than the header, for an object |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
820 that isn't variable-size. Objects that are variable-size need to use |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
821 zero_sized_lisp_object(). |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
822 */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
823 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
824 void |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
825 zero_nonsized_lisp_object (Lisp_Object obj) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
826 { |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
827 const struct lrecord_implementation *imp = |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
828 XRECORD_LHEADER_IMPLEMENTATION (obj); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
829 assert (!imp->size_in_bytes_method); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
830 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
831 zero_sized_lisp_object (obj, lisp_object_size (obj)); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
832 } |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
833 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
834 void |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
835 free_normal_lisp_object (Lisp_Object obj) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
836 { |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
837 #ifndef NEW_GC |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
838 const struct lrecord_implementation *imp = |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
839 XRECORD_LHEADER_IMPLEMENTATION (obj); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
840 #endif /* not NEW_GC */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
841 |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
842 #ifdef NEW_GC |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
843 /* Manual frees are not allowed with asynchronous finalization */ |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
844 return; |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
845 #else |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
846 assert (!imp->frob_block_p); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
847 assert (!imp->size_in_bytes_method); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
848 old_free_lcrecord (obj); |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
849 #endif |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
850 } |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
851 |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
852 #ifndef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
853 int |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
854 c_readonly (Lisp_Object obj) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
855 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
856 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
857 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
858 #endif /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
859 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
860 int |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
861 lisp_readonly (Lisp_Object obj) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
862 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
863 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
864 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
865 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
866 /* #### Should be made into an object method */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
867 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
868 int |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
869 object_dead_p (Lisp_Object obj) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
870 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
871 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
872 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
873 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
874 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
875 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
876 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
877 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
878 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
879 |
428 | 880 |
881 /************************************************************************/ | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
882 /* Debugger support */ |
428 | 883 /************************************************************************/ |
884 /* Give gdb/dbx enough information to decode Lisp Objects. We make | |
885 sure certain symbols are always defined, so gdb doesn't complain | |
438 | 886 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc |
887 to see how this is used. */ | |
428 | 888 |
458 | 889 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS; |
890 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1; | |
428 | 891 |
892 #ifdef USE_UNION_TYPE | |
458 | 893 unsigned char dbg_USE_UNION_TYPE = 1; |
428 | 894 #else |
458 | 895 unsigned char dbg_USE_UNION_TYPE = 0; |
428 | 896 #endif |
897 | |
458 | 898 unsigned char dbg_valbits = VALBITS; |
899 unsigned char dbg_gctypebits = GCTYPEBITS; | |
900 | |
901 /* On some systems, the above definitions will be optimized away by | |
902 the compiler or linker unless they are referenced in some function. */ | |
903 long dbg_inhibit_dbg_symbol_deletion (void); | |
904 long | |
905 dbg_inhibit_dbg_symbol_deletion (void) | |
906 { | |
907 return | |
908 (dbg_valmask + | |
909 dbg_typemask + | |
910 dbg_USE_UNION_TYPE + | |
911 dbg_valbits + | |
912 dbg_gctypebits); | |
913 } | |
428 | 914 |
915 /* Macros turned into functions for ease of debugging. | |
916 Debuggers don't know about macros! */ | |
917 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); | |
918 int | |
919 dbg_eq (Lisp_Object obj1, Lisp_Object obj2) | |
920 { | |
921 return EQ (obj1, obj2); | |
922 } | |
923 | |
924 | |
3263 | 925 #ifdef NEW_GC |
3017 | 926 #define DECLARE_FIXED_TYPE_ALLOC(type, structture) struct __foo__ |
927 #else | |
428 | 928 /************************************************************************/ |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
929 /* Fixed-size type macros */ |
428 | 930 /************************************************************************/ |
931 | |
932 /* For fixed-size types that are commonly used, we malloc() large blocks | |
933 of memory at a time and subdivide them into chunks of the correct | |
934 size for an object of that type. This is more efficient than | |
935 malloc()ing each object separately because we save on malloc() time | |
936 and overhead due to the fewer number of malloc()ed blocks, and | |
937 also because we don't need any extra pointers within each object | |
938 to keep them threaded together for GC purposes. For less common | |
939 (and frequently large-size) types, we use lcrecords, which are | |
940 malloc()ed individually and chained together through a pointer | |
941 in the lcrecord header. lcrecords do not need to be fixed-size | |
942 (i.e. two objects of the same type need not have the same size; | |
943 however, the size of a particular object cannot vary dynamically). | |
944 It is also much easier to create a new lcrecord type because no | |
945 additional code needs to be added to alloc.c. Finally, lcrecords | |
946 may be more efficient when there are only a small number of them. | |
947 | |
948 The types that are stored in these large blocks (or "frob blocks") | |
1983 | 949 are cons, all number types except fixnum, compiled-function, symbol, |
950 marker, extent, event, and string. | |
428 | 951 |
952 Note that strings are special in that they are actually stored in | |
953 two parts: a structure containing information about the string, and | |
954 the actual data associated with the string. The former structure | |
955 (a struct Lisp_String) is a fixed-size structure and is managed the | |
956 same way as all the other such types. This structure contains a | |
957 pointer to the actual string data, which is stored in structures of | |
958 type struct string_chars_block. Each string_chars_block consists | |
959 of a pointer to a struct Lisp_String, followed by the data for that | |
440 | 960 string, followed by another pointer to a Lisp_String, followed by |
961 the data for that string, etc. At GC time, the data in these | |
962 blocks is compacted by searching sequentially through all the | |
428 | 963 blocks and compressing out any holes created by unmarked strings. |
964 Strings that are more than a certain size (bigger than the size of | |
965 a string_chars_block, although something like half as big might | |
966 make more sense) are malloc()ed separately and not stored in | |
967 string_chars_blocks. Furthermore, no one string stretches across | |
968 two string_chars_blocks. | |
969 | |
1204 | 970 Vectors are each malloc()ed separately as lcrecords. |
428 | 971 |
972 In the following discussion, we use conses, but it applies equally | |
973 well to the other fixed-size types. | |
974 | |
975 We store cons cells inside of cons_blocks, allocating a new | |
976 cons_block with malloc() whenever necessary. Cons cells reclaimed | |
977 by GC are put on a free list to be reallocated before allocating | |
978 any new cons cells from the latest cons_block. Each cons_block is | |
979 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least | |
980 the versions in malloc.c and gmalloc.c) really allocates in units | |
981 of powers of two and uses 4 bytes for its own overhead. | |
982 | |
983 What GC actually does is to search through all the cons_blocks, | |
984 from the most recently allocated to the oldest, and put all | |
985 cons cells that are not marked (whether or not they're already | |
986 free) on a cons_free_list. The cons_free_list is a stack, and | |
987 so the cons cells in the oldest-allocated cons_block end up | |
988 at the head of the stack and are the first to be reallocated. | |
989 If any cons_block is entirely free, it is freed with free() | |
990 and its cons cells removed from the cons_free_list. Because | |
991 the cons_free_list ends up basically in memory order, we have | |
992 a high locality of reference (assuming a reasonable turnover | |
993 of allocating and freeing) and have a reasonable probability | |
994 of entirely freeing up cons_blocks that have been more recently | |
995 allocated. This stage is called the "sweep stage" of GC, and | |
996 is executed after the "mark stage", which involves starting | |
997 from all places that are known to point to in-use Lisp objects | |
998 (e.g. the obarray, where are all symbols are stored; the | |
999 current catches and condition-cases; the backtrace list of | |
1000 currently executing functions; the gcpro list; etc.) and | |
1001 recursively marking all objects that are accessible. | |
1002 | |
454 | 1003 At the beginning of the sweep stage, the conses in the cons blocks |
1004 are in one of three states: in use and marked, in use but not | |
1005 marked, and not in use (already freed). Any conses that are marked | |
1006 have been marked in the mark stage just executed, because as part | |
1007 of the sweep stage we unmark any marked objects. The way we tell | |
1008 whether or not a cons cell is in use is through the LRECORD_FREE_P | |
1009 macro. This uses a special lrecord type `lrecord_type_free', | |
1010 which is never associated with any valid object. | |
1011 | |
1012 Conses on the free_cons_list are threaded through a pointer stored | |
1013 in the conses themselves. Because the cons is still in a | |
1014 cons_block and needs to remain marked as not in use for the next | |
1015 time that GC happens, we need room to store both the "free" | |
1016 indicator and the chaining pointer. So this pointer is stored | |
1017 after the lrecord header (actually where C places a pointer after | |
1018 the lrecord header; they are not necessarily contiguous). This | |
1019 implies that all fixed-size types must be big enough to contain at | |
1020 least one pointer. This is true for all current fixed-size types, | |
1021 with the possible exception of Lisp_Floats, for which we define the | |
1022 meat of the struct using a union of a pointer and a double to | |
1023 ensure adequate space for the free list chain pointer. | |
428 | 1024 |
1025 Some types of objects need additional "finalization" done | |
1026 when an object is converted from in use to not in use; | |
1027 this is the purpose of the ADDITIONAL_FREE_type macro. | |
1028 For example, markers need to be removed from the chain | |
1029 of markers that is kept in each buffer. This is because | |
1030 markers in a buffer automatically disappear if the marker | |
1031 is no longer referenced anywhere (the same does not | |
1032 apply to extents, however). | |
1033 | |
1034 WARNING: Things are in an extremely bizarre state when | |
1035 the ADDITIONAL_FREE_type macros are called, so beware! | |
1036 | |
454 | 1037 When ERROR_CHECK_GC is defined, we do things differently so as to |
1038 maximize our chances of catching places where there is insufficient | |
1039 GCPROing. The thing we want to avoid is having an object that | |
1040 we're using but didn't GCPRO get freed by GC and then reallocated | |
1041 while we're in the process of using it -- this will result in | |
1042 something seemingly unrelated getting trashed, and is extremely | |
1043 difficult to track down. If the object gets freed but not | |
1044 reallocated, we can usually catch this because we set most of the | |
1045 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set | |
1046 to the invalid type `lrecord_type_free', however, and a pointer | |
1047 used to chain freed objects together is stored after the lrecord | |
1048 header; we play some tricks with this pointer to make it more | |
428 | 1049 bogus, so crashes are more likely to occur right away.) |
1050 | |
1051 We want freed objects to stay free as long as possible, | |
1052 so instead of doing what we do above, we maintain the | |
1053 free objects in a first-in first-out queue. We also | |
1054 don't recompute the free list each GC, unlike above; | |
1055 this ensures that the queue ordering is preserved. | |
1056 [This means that we are likely to have worse locality | |
1057 of reference, and that we can never free a frob block | |
1058 once it's allocated. (Even if we know that all cells | |
1059 in it are free, there's no easy way to remove all those | |
1060 cells from the free list because the objects on the | |
1061 free list are unlikely to be in memory order.)] | |
1062 Furthermore, we never take objects off the free list | |
1063 unless there's a large number (usually 1000, but | |
1064 varies depending on type) of them already on the list. | |
1065 This way, we ensure that an object that gets freed will | |
1066 remain free for the next 1000 (or whatever) times that | |
440 | 1067 an object of that type is allocated. */ |
428 | 1068 |
1069 #ifdef ALLOC_NO_POOLS | |
1070 # define TYPE_ALLOC_SIZE(type, structtype) 1 | |
1071 #else | |
1072 # define TYPE_ALLOC_SIZE(type, structtype) \ | |
1073 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ | |
1074 / sizeof (structtype)) | |
1075 #endif /* ALLOC_NO_POOLS */ | |
1076 | |
1077 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ | |
1078 \ | |
1079 struct type##_block \ | |
1080 { \ | |
1081 struct type##_block *prev; \ | |
1082 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ | |
1083 }; \ | |
1084 \ | |
1085 static struct type##_block *current_##type##_block; \ | |
1086 static int current_##type##_block_index; \ | |
1087 \ | |
454 | 1088 static Lisp_Free *type##_free_list; \ |
1089 static Lisp_Free *type##_free_list_tail; \ | |
428 | 1090 \ |
1091 static void \ | |
1092 init_##type##_alloc (void) \ | |
1093 { \ | |
1094 current_##type##_block = 0; \ | |
1095 current_##type##_block_index = \ | |
1096 countof (current_##type##_block->block); \ | |
1097 type##_free_list = 0; \ | |
1098 type##_free_list_tail = 0; \ | |
1099 } \ | |
1100 \ | |
1101 static int gc_count_num_##type##_in_use; \ | |
1102 static int gc_count_num_##type##_freelist | |
1103 | |
1104 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ | |
1105 if (current_##type##_block_index \ | |
1106 == countof (current_##type##_block->block)) \ | |
1107 { \ | |
1108 struct type##_block *AFTFB_new = (struct type##_block *) \ | |
1109 allocate_lisp_storage (sizeof (struct type##_block)); \ | |
1110 AFTFB_new->prev = current_##type##_block; \ | |
1111 current_##type##_block = AFTFB_new; \ | |
1112 current_##type##_block_index = 0; \ | |
1113 } \ | |
1114 (result) = \ | |
1115 &(current_##type##_block->block[current_##type##_block_index++]); \ | |
1116 } while (0) | |
1117 | |
1118 /* Allocate an instance of a type that is stored in blocks. | |
1119 TYPE is the "name" of the type, STRUCTTYPE is the corresponding | |
1120 structure type. */ | |
1121 | |
1122 #ifdef ERROR_CHECK_GC | |
1123 | |
1124 /* Note: if you get crashes in this function, suspect incorrect calls | |
1125 to free_cons() and friends. This happened once because the cons | |
1126 cell was not GC-protected and was getting collected before | |
1127 free_cons() was called. */ | |
1128 | |
454 | 1129 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
1130 if (gc_count_num_##type##_freelist > \ | |
1131 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \ | |
1132 { \ | |
1133 result = (structtype *) type##_free_list; \ | |
1204 | 1134 assert (LRECORD_FREE_P (result)); \ |
1135 /* Before actually using the chain pointer, we complement \ | |
1136 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \ | |
454 | 1137 type##_free_list = (Lisp_Free *) \ |
1138 (~ (EMACS_UINT) (type##_free_list->chain)); \ | |
1139 gc_count_num_##type##_freelist--; \ | |
1140 } \ | |
1141 else \ | |
1142 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
1143 MARK_LRECORD_AS_NOT_FREE (result); \ | |
428 | 1144 } while (0) |
1145 | |
1146 #else /* !ERROR_CHECK_GC */ | |
1147 | |
454 | 1148 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
428 | 1149 if (type##_free_list) \ |
1150 { \ | |
454 | 1151 result = (structtype *) type##_free_list; \ |
1152 type##_free_list = type##_free_list->chain; \ | |
428 | 1153 } \ |
1154 else \ | |
1155 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
454 | 1156 MARK_LRECORD_AS_NOT_FREE (result); \ |
428 | 1157 } while (0) |
1158 | |
1159 #endif /* !ERROR_CHECK_GC */ | |
1160 | |
454 | 1161 |
428 | 1162 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \ |
1163 do \ | |
1164 { \ | |
1165 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
1166 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
1167 } while (0) | |
1168 | |
1169 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \ | |
1170 do \ | |
1171 { \ | |
1172 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
1173 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
1174 } while (0) | |
1175 | |
454 | 1176 /* Lisp_Free is the type to represent a free list member inside a frob |
1177 block of any lisp object type. */ | |
1178 typedef struct Lisp_Free | |
1179 { | |
1180 struct lrecord_header lheader; | |
1181 struct Lisp_Free *chain; | |
1182 } Lisp_Free; | |
1183 | |
1184 #define LRECORD_FREE_P(ptr) \ | |
771 | 1185 (((struct lrecord_header *) ptr)->type == lrecord_type_free) |
454 | 1186 |
1187 #define MARK_LRECORD_AS_FREE(ptr) \ | |
771 | 1188 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free)) |
454 | 1189 |
1190 #ifdef ERROR_CHECK_GC | |
1191 #define MARK_LRECORD_AS_NOT_FREE(ptr) \ | |
771 | 1192 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined)) |
428 | 1193 #else |
454 | 1194 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING |
428 | 1195 #endif |
1196 | |
1197 #ifdef ERROR_CHECK_GC | |
1198 | |
454 | 1199 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
1200 if (type##_free_list_tail) \ | |
1201 { \ | |
1202 /* When we store the chain pointer, we complement all \ | |
1203 its bits; this should significantly increase its \ | |
1204 bogosity in case someone tries to use the value, and \ | |
1205 should make us crash faster if someone overwrites the \ | |
1206 pointer because when it gets un-complemented in \ | |
1207 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \ | |
1208 extremely bogus. */ \ | |
1209 type##_free_list_tail->chain = \ | |
1210 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \ | |
1211 } \ | |
1212 else \ | |
1213 type##_free_list = (Lisp_Free *) (ptr); \ | |
1214 type##_free_list_tail = (Lisp_Free *) (ptr); \ | |
1215 } while (0) | |
428 | 1216 |
1217 #else /* !ERROR_CHECK_GC */ | |
1218 | |
454 | 1219 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
1220 ((Lisp_Free *) (ptr))->chain = type##_free_list; \ | |
1221 type##_free_list = (Lisp_Free *) (ptr); \ | |
1222 } while (0) \ | |
428 | 1223 |
1224 #endif /* !ERROR_CHECK_GC */ | |
1225 | |
1226 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ | |
1227 | |
1228 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \ | |
1229 structtype *FFT_ptr = (ptr); \ | |
1204 | 1230 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \ |
2367 | 1231 gc_checking_assert (!DUMPEDP (FFT_ptr)); \ |
428 | 1232 ADDITIONAL_FREE_##type (FFT_ptr); \ |
1233 deadbeef_memory (FFT_ptr, sizeof (structtype)); \ | |
1234 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ | |
454 | 1235 MARK_LRECORD_AS_FREE (FFT_ptr); \ |
428 | 1236 } while (0) |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1237 #endif /* NEW_GC */ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1238 |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1239 #ifdef NEW_GC |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1240 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \ |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1241 free_normal_lisp_object (lo) |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1242 #else /* not NEW_GC */ |
428 | 1243 /* Like FREE_FIXED_TYPE() but used when we are explicitly |
1244 freeing a structure through free_cons(), free_marker(), etc. | |
1245 rather than through the normal process of sweeping. | |
1246 We attempt to undo the changes made to the allocation counters | |
1247 as a result of this structure being allocated. This is not | |
1248 completely necessary but helps keep things saner: e.g. this way, | |
1249 repeatedly allocating and freeing a cons will not result in | |
1250 the consing-since-gc counter advancing, which would cause a GC | |
1204 | 1251 and somewhat defeat the purpose of explicitly freeing. |
1252 | |
1253 We also disable this mechanism entirely when ALLOC_NO_POOLS is | |
1254 set, which is used for Purify and the like. */ | |
1255 | |
1256 #ifndef ALLOC_NO_POOLS | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1257 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1258 do { FREE_FIXED_TYPE (type, structtype, ptr); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1259 DECREMENT_CONS_COUNTER (sizeof (structtype)); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1260 gc_count_num_##type##_freelist++; \ |
428 | 1261 } while (0) |
1204 | 1262 #else |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1263 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) |
1204 | 1264 #endif |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
1265 #endif /* (not) NEW_GC */ |
3263 | 1266 |
1267 #ifdef NEW_GC | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1268 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\ |
3017 | 1269 do { \ |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1270 (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \ |
3017 | 1271 } while (0) |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1272 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ |
3017 | 1273 lrec_ptr) \ |
1274 do { \ | |
5120
d1247f3cc363
latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
1275 (var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr)); \ |
3017 | 1276 } while (0) |
3263 | 1277 #else /* not NEW_GC */ |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1278 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ |
3017 | 1279 do \ |
1280 { \ | |
1281 ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ | |
1282 set_lheader_implementation (&(var)->lheader, lrec_ptr); \ | |
1283 } while (0) | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1284 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ |
3017 | 1285 lrec_ptr) \ |
1286 do \ | |
1287 { \ | |
1288 NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ | |
1289 set_lheader_implementation (&(var)->lheader, lrec_ptr); \ | |
1290 } while (0) | |
3263 | 1291 #endif /* not NEW_GC */ |
3017 | 1292 |
428 | 1293 |
1294 | |
1295 /************************************************************************/ | |
1296 /* Cons allocation */ | |
1297 /************************************************************************/ | |
1298 | |
440 | 1299 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons); |
428 | 1300 /* conses are used and freed so often that we set this really high */ |
1301 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ | |
1302 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 | |
1303 | |
1304 static Lisp_Object | |
1305 mark_cons (Lisp_Object obj) | |
1306 { | |
1307 if (NILP (XCDR (obj))) | |
1308 return XCAR (obj); | |
1309 | |
1310 mark_object (XCAR (obj)); | |
1311 return XCDR (obj); | |
1312 } | |
1313 | |
1314 static int | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1315 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth, int foldcase) |
428 | 1316 { |
442 | 1317 depth++; |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1318 while (internal_equal_0 (XCAR (ob1), XCAR (ob2), depth, foldcase)) |
428 | 1319 { |
1320 ob1 = XCDR (ob1); | |
1321 ob2 = XCDR (ob2); | |
1322 if (! CONSP (ob1) || ! CONSP (ob2)) | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1323 return internal_equal_0 (ob1, ob2, depth, foldcase); |
428 | 1324 } |
1325 return 0; | |
1326 } | |
1327 | |
1204 | 1328 static const struct memory_description cons_description[] = { |
853 | 1329 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) }, |
1330 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) }, | |
428 | 1331 { XD_END } |
1332 }; | |
1333 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1334 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("cons", cons, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1335 mark_cons, print_cons, 0, cons_equal, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1336 /* |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1337 * No `hash' method needed. |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1338 * internal_hash knows how to |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1339 * handle conses. |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1340 */ |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1341 0, cons_description, Lisp_Cons); |
428 | 1342 |
1343 DEFUN ("cons", Fcons, 2, 2, 0, /* | |
3355 | 1344 Create a new cons cell, give it CAR and CDR as components, and return it. |
1345 | |
1346 A cons cell is a Lisp object (an area in memory) made up of two pointers | |
1347 called the CAR and the CDR. Each of these pointers can point to any other | |
1348 Lisp object. The common Lisp data type, the list, is a specially-structured | |
1349 series of cons cells. | |
1350 | |
1351 The pointers are accessed from Lisp with `car' and `cdr', and mutated with | |
1352 `setcar' and `setcdr' respectively. For historical reasons, the aliases | |
1353 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported. | |
428 | 1354 */ |
1355 (car, cdr)) | |
1356 { | |
1357 /* This cannot GC. */ | |
1358 Lisp_Object val; | |
440 | 1359 Lisp_Cons *c; |
1360 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1361 ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); |
793 | 1362 val = wrap_cons (c); |
853 | 1363 XSETCAR (val, car); |
1364 XSETCDR (val, cdr); | |
428 | 1365 return val; |
1366 } | |
1367 | |
1368 /* This is identical to Fcons() but it used for conses that we're | |
1369 going to free later, and is useful when trying to track down | |
1370 "real" consing. */ | |
1371 Lisp_Object | |
1372 noseeum_cons (Lisp_Object car, Lisp_Object cdr) | |
1373 { | |
1374 Lisp_Object val; | |
440 | 1375 Lisp_Cons *c; |
1376 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1377 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); |
793 | 1378 val = wrap_cons (c); |
428 | 1379 XCAR (val) = car; |
1380 XCDR (val) = cdr; | |
1381 return val; | |
1382 } | |
1383 | |
1384 DEFUN ("list", Flist, 0, MANY, 0, /* | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1385 Return a newly created list with specified ARGS as elements. |
428 | 1386 Any number of arguments, even zero arguments, are allowed. |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1387 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1388 arguments: (&rest ARGS) |
428 | 1389 */ |
1390 (int nargs, Lisp_Object *args)) | |
1391 { | |
1392 Lisp_Object val = Qnil; | |
1393 Lisp_Object *argp = args + nargs; | |
1394 | |
1395 while (argp > args) | |
1396 val = Fcons (*--argp, val); | |
1397 return val; | |
1398 } | |
1399 | |
1400 Lisp_Object | |
1401 list1 (Lisp_Object obj0) | |
1402 { | |
1403 /* This cannot GC. */ | |
1404 return Fcons (obj0, Qnil); | |
1405 } | |
1406 | |
1407 Lisp_Object | |
1408 list2 (Lisp_Object obj0, Lisp_Object obj1) | |
1409 { | |
1410 /* This cannot GC. */ | |
1411 return Fcons (obj0, Fcons (obj1, Qnil)); | |
1412 } | |
1413 | |
1414 Lisp_Object | |
1415 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
1416 { | |
1417 /* This cannot GC. */ | |
1418 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil))); | |
1419 } | |
1420 | |
1421 Lisp_Object | |
1422 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
1423 { | |
1424 /* This cannot GC. */ | |
1425 return Fcons (obj0, Fcons (obj1, obj2)); | |
1426 } | |
1427 | |
1428 Lisp_Object | |
1429 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist) | |
1430 { | |
1431 return Fcons (Fcons (key, value), alist); | |
1432 } | |
1433 | |
1434 Lisp_Object | |
1435 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3) | |
1436 { | |
1437 /* This cannot GC. */ | |
1438 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil)))); | |
1439 } | |
1440 | |
1441 Lisp_Object | |
1442 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
1443 Lisp_Object obj4) | |
1444 { | |
1445 /* This cannot GC. */ | |
1446 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil))))); | |
1447 } | |
1448 | |
1449 Lisp_Object | |
1450 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
1451 Lisp_Object obj4, Lisp_Object obj5) | |
1452 { | |
1453 /* This cannot GC. */ | |
1454 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil)))))); | |
1455 } | |
1456 | |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1457 /* Return a list of arbitrary length, terminated by Qunbound. */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1458 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1459 Lisp_Object |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1460 listu (Lisp_Object first, ...) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1461 { |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1462 Lisp_Object obj = Qnil; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1463 Lisp_Object val; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1464 va_list va; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1465 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1466 va_start (va, first); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1467 val = first; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1468 while (!UNBOUNDP (val)) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1469 { |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1470 obj = Fcons (val, obj); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1471 val = va_arg (va, Lisp_Object); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1472 } |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1473 va_end (va); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1474 return Fnreverse (obj); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1475 } |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1476 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1477 /* Return a list of arbitrary length, with length specified and remaining |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1478 args making up the list. */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1479 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1480 Lisp_Object |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1481 listn (int num_args, ...) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1482 { |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1483 int i; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1484 Lisp_Object obj = Qnil; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1485 va_list va; |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1486 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1487 va_start (va, num_args); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1488 for (i = 0; i < num_args; i++) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1489 obj = Fcons (va_arg (va, Lisp_Object), obj); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1490 va_end (va); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1491 return Fnreverse (obj); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1492 } |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1493 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1494 /* Return a list of arbitrary length, with length specified and an array |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1495 of elements. */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
1496 |
428 | 1497 DEFUN ("make-list", Fmake_list, 2, 2, 0, /* |
444 | 1498 Return a new list of length LENGTH, with each element being OBJECT. |
428 | 1499 */ |
444 | 1500 (length, object)) |
428 | 1501 { |
1502 CHECK_NATNUM (length); | |
1503 | |
1504 { | |
1505 Lisp_Object val = Qnil; | |
647 | 1506 EMACS_INT size = XINT (length); |
428 | 1507 |
1508 while (size--) | |
444 | 1509 val = Fcons (object, val); |
428 | 1510 return val; |
1511 } | |
1512 } | |
1513 | |
1514 | |
1515 /************************************************************************/ | |
1516 /* Float allocation */ | |
1517 /************************************************************************/ | |
1518 | |
1983 | 1519 /*** With enhanced number support, these are short floats */ |
1520 | |
440 | 1521 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); |
428 | 1522 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 |
1523 | |
1524 Lisp_Object | |
1525 make_float (double float_value) | |
1526 { | |
440 | 1527 Lisp_Float *f; |
1528 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1529 ALLOC_FROB_BLOCK_LISP_OBJECT (float, Lisp_Float, f, &lrecord_float); |
440 | 1530 |
1531 /* Avoid dump-time `uninitialized memory read' purify warnings. */ | |
1532 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1533 zero_nonsized_lisp_object (wrap_float (f)); |
3017 | 1534 |
428 | 1535 float_data (f) = float_value; |
793 | 1536 return wrap_float (f); |
428 | 1537 } |
1538 | |
1539 | |
1540 /************************************************************************/ | |
1983 | 1541 /* Enhanced number allocation */ |
1542 /************************************************************************/ | |
1543 | |
1544 /*** Bignum ***/ | |
1545 #ifdef HAVE_BIGNUM | |
1546 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); | |
1547 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 | |
1548 | |
1549 /* WARNING: This function returns a bignum even if its argument fits into a | |
1550 fixnum. See Fcanonicalize_number(). */ | |
1551 Lisp_Object | |
1552 make_bignum (long bignum_value) | |
1553 { | |
1554 Lisp_Bignum *b; | |
1555 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1556 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); |
1983 | 1557 bignum_init (bignum_data (b)); |
1558 bignum_set_long (bignum_data (b), bignum_value); | |
1559 return wrap_bignum (b); | |
1560 } | |
1561 | |
1562 /* WARNING: This function returns a bignum even if its argument fits into a | |
1563 fixnum. See Fcanonicalize_number(). */ | |
1564 Lisp_Object | |
1565 make_bignum_bg (bignum bg) | |
1566 { | |
1567 Lisp_Bignum *b; | |
1568 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1569 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); |
1983 | 1570 bignum_init (bignum_data (b)); |
1571 bignum_set (bignum_data (b), bg); | |
1572 return wrap_bignum (b); | |
1573 } | |
1574 #endif /* HAVE_BIGNUM */ | |
1575 | |
1576 /*** Ratio ***/ | |
1577 #ifdef HAVE_RATIO | |
1578 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio); | |
1579 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250 | |
1580 | |
1581 Lisp_Object | |
1582 make_ratio (long numerator, unsigned long denominator) | |
1583 { | |
1584 Lisp_Ratio *r; | |
1585 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1586 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
1983 | 1587 ratio_init (ratio_data (r)); |
1588 ratio_set_long_ulong (ratio_data (r), numerator, denominator); | |
1589 ratio_canonicalize (ratio_data (r)); | |
1590 return wrap_ratio (r); | |
1591 } | |
1592 | |
1593 Lisp_Object | |
1594 make_ratio_bg (bignum numerator, bignum denominator) | |
1595 { | |
1596 Lisp_Ratio *r; | |
1597 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1598 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
1983 | 1599 ratio_init (ratio_data (r)); |
1600 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); | |
1601 ratio_canonicalize (ratio_data (r)); | |
1602 return wrap_ratio (r); | |
1603 } | |
1604 | |
1605 Lisp_Object | |
1606 make_ratio_rt (ratio rat) | |
1607 { | |
1608 Lisp_Ratio *r; | |
1609 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1610 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); |
1983 | 1611 ratio_init (ratio_data (r)); |
1612 ratio_set (ratio_data (r), rat); | |
1613 return wrap_ratio (r); | |
1614 } | |
1615 #endif /* HAVE_RATIO */ | |
1616 | |
1617 /*** Bigfloat ***/ | |
1618 #ifdef HAVE_BIGFLOAT | |
1619 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat); | |
1620 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250 | |
1621 | |
1622 /* This function creates a bigfloat with the default precision if the | |
1623 PRECISION argument is zero. */ | |
1624 Lisp_Object | |
1625 make_bigfloat (double float_value, unsigned long precision) | |
1626 { | |
1627 Lisp_Bigfloat *f; | |
1628 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1629 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); |
1983 | 1630 if (precision == 0UL) |
1631 bigfloat_init (bigfloat_data (f)); | |
1632 else | |
1633 bigfloat_init_prec (bigfloat_data (f), precision); | |
1634 bigfloat_set_double (bigfloat_data (f), float_value); | |
1635 return wrap_bigfloat (f); | |
1636 } | |
1637 | |
1638 /* This function creates a bigfloat with the precision of its argument */ | |
1639 Lisp_Object | |
1640 make_bigfloat_bf (bigfloat float_value) | |
1641 { | |
1642 Lisp_Bigfloat *f; | |
1643 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1644 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); |
1983 | 1645 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); |
1646 bigfloat_set (bigfloat_data (f), float_value); | |
1647 return wrap_bigfloat (f); | |
1648 } | |
1649 #endif /* HAVE_BIGFLOAT */ | |
1650 | |
1651 /************************************************************************/ | |
428 | 1652 /* Vector allocation */ |
1653 /************************************************************************/ | |
1654 | |
1655 static Lisp_Object | |
1656 mark_vector (Lisp_Object obj) | |
1657 { | |
1658 Lisp_Vector *ptr = XVECTOR (obj); | |
1659 int len = vector_length (ptr); | |
1660 int i; | |
1661 | |
1662 for (i = 0; i < len - 1; i++) | |
1663 mark_object (ptr->contents[i]); | |
1664 return (len > 0) ? ptr->contents[len - 1] : Qnil; | |
1665 } | |
1666 | |
665 | 1667 static Bytecount |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1668 size_vector (Lisp_Object obj) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1669 { |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1670 |
456 | 1671 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1672 XVECTOR (obj)->size); |
428 | 1673 } |
1674 | |
1675 static int | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1676 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
428 | 1677 { |
1678 int len = XVECTOR_LENGTH (obj1); | |
1679 if (len != XVECTOR_LENGTH (obj2)) | |
1680 return 0; | |
1681 | |
1682 { | |
1683 Lisp_Object *ptr1 = XVECTOR_DATA (obj1); | |
1684 Lisp_Object *ptr2 = XVECTOR_DATA (obj2); | |
1685 while (len--) | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
1686 if (!internal_equal_0 (*ptr1++, *ptr2++, depth + 1, foldcase)) |
428 | 1687 return 0; |
1688 } | |
1689 return 1; | |
1690 } | |
1691 | |
665 | 1692 static Hashcode |
442 | 1693 vector_hash (Lisp_Object obj, int depth) |
1694 { | |
1695 return HASH2 (XVECTOR_LENGTH (obj), | |
1696 internal_array_hash (XVECTOR_DATA (obj), | |
1697 XVECTOR_LENGTH (obj), | |
1698 depth + 1)); | |
1699 } | |
1700 | |
1204 | 1701 static const struct memory_description vector_description[] = { |
440 | 1702 { XD_LONG, offsetof (Lisp_Vector, size) }, |
1703 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) }, | |
428 | 1704 { XD_END } |
1705 }; | |
1706 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1707 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("vector", vector, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1708 mark_vector, print_vector, 0, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1709 vector_equal, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1710 vector_hash, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1711 vector_description, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1712 size_vector, Lisp_Vector); |
428 | 1713 /* #### should allocate `small' vectors from a frob-block */ |
1714 static Lisp_Vector * | |
665 | 1715 make_vector_internal (Elemcount sizei) |
428 | 1716 { |
1204 | 1717 /* no `next' field; we use lcrecords */ |
665 | 1718 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, |
1204 | 1719 contents, sizei); |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1720 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, vector); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1721 Lisp_Vector *p = XVECTOR (obj); |
428 | 1722 |
1723 p->size = sizei; | |
1724 return p; | |
1725 } | |
1726 | |
1727 Lisp_Object | |
665 | 1728 make_vector (Elemcount length, Lisp_Object object) |
428 | 1729 { |
1730 Lisp_Vector *vecp = make_vector_internal (length); | |
1731 Lisp_Object *p = vector_data (vecp); | |
1732 | |
1733 while (length--) | |
444 | 1734 *p++ = object; |
428 | 1735 |
793 | 1736 return wrap_vector (vecp); |
428 | 1737 } |
1738 | |
1739 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /* | |
444 | 1740 Return a new vector of length LENGTH, with each element being OBJECT. |
428 | 1741 See also the function `vector'. |
1742 */ | |
444 | 1743 (length, object)) |
428 | 1744 { |
1745 CONCHECK_NATNUM (length); | |
444 | 1746 return make_vector (XINT (length), object); |
428 | 1747 } |
1748 | |
1749 DEFUN ("vector", Fvector, 0, MANY, 0, /* | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1750 Return a newly created vector with specified ARGS as elements. |
428 | 1751 Any number of arguments, even zero arguments, are allowed. |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1752 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1753 arguments: (&rest ARGS) |
428 | 1754 */ |
1755 (int nargs, Lisp_Object *args)) | |
1756 { | |
1757 Lisp_Vector *vecp = make_vector_internal (nargs); | |
1758 Lisp_Object *p = vector_data (vecp); | |
1759 | |
1760 while (nargs--) | |
1761 *p++ = *args++; | |
1762 | |
793 | 1763 return wrap_vector (vecp); |
428 | 1764 } |
1765 | |
1766 Lisp_Object | |
1767 vector1 (Lisp_Object obj0) | |
1768 { | |
1769 return Fvector (1, &obj0); | |
1770 } | |
1771 | |
1772 Lisp_Object | |
1773 vector2 (Lisp_Object obj0, Lisp_Object obj1) | |
1774 { | |
1775 Lisp_Object args[2]; | |
1776 args[0] = obj0; | |
1777 args[1] = obj1; | |
1778 return Fvector (2, args); | |
1779 } | |
1780 | |
1781 Lisp_Object | |
1782 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
1783 { | |
1784 Lisp_Object args[3]; | |
1785 args[0] = obj0; | |
1786 args[1] = obj1; | |
1787 args[2] = obj2; | |
1788 return Fvector (3, args); | |
1789 } | |
1790 | |
1791 #if 0 /* currently unused */ | |
1792 | |
1793 Lisp_Object | |
1794 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
1795 Lisp_Object obj3) | |
1796 { | |
1797 Lisp_Object args[4]; | |
1798 args[0] = obj0; | |
1799 args[1] = obj1; | |
1800 args[2] = obj2; | |
1801 args[3] = obj3; | |
1802 return Fvector (4, args); | |
1803 } | |
1804 | |
1805 Lisp_Object | |
1806 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
1807 Lisp_Object obj3, Lisp_Object obj4) | |
1808 { | |
1809 Lisp_Object args[5]; | |
1810 args[0] = obj0; | |
1811 args[1] = obj1; | |
1812 args[2] = obj2; | |
1813 args[3] = obj3; | |
1814 args[4] = obj4; | |
1815 return Fvector (5, args); | |
1816 } | |
1817 | |
1818 Lisp_Object | |
1819 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
1820 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5) | |
1821 { | |
1822 Lisp_Object args[6]; | |
1823 args[0] = obj0; | |
1824 args[1] = obj1; | |
1825 args[2] = obj2; | |
1826 args[3] = obj3; | |
1827 args[4] = obj4; | |
1828 args[5] = obj5; | |
1829 return Fvector (6, args); | |
1830 } | |
1831 | |
1832 Lisp_Object | |
1833 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
1834 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
1835 Lisp_Object obj6) | |
1836 { | |
1837 Lisp_Object args[7]; | |
1838 args[0] = obj0; | |
1839 args[1] = obj1; | |
1840 args[2] = obj2; | |
1841 args[3] = obj3; | |
1842 args[4] = obj4; | |
1843 args[5] = obj5; | |
1844 args[6] = obj6; | |
1845 return Fvector (7, args); | |
1846 } | |
1847 | |
1848 Lisp_Object | |
1849 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
1850 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
1851 Lisp_Object obj6, Lisp_Object obj7) | |
1852 { | |
1853 Lisp_Object args[8]; | |
1854 args[0] = obj0; | |
1855 args[1] = obj1; | |
1856 args[2] = obj2; | |
1857 args[3] = obj3; | |
1858 args[4] = obj4; | |
1859 args[5] = obj5; | |
1860 args[6] = obj6; | |
1861 args[7] = obj7; | |
1862 return Fvector (8, args); | |
1863 } | |
1864 #endif /* unused */ | |
1865 | |
1866 /************************************************************************/ | |
1867 /* Bit Vector allocation */ | |
1868 /************************************************************************/ | |
1869 | |
1870 /* #### should allocate `small' bit vectors from a frob-block */ | |
440 | 1871 static Lisp_Bit_Vector * |
665 | 1872 make_bit_vector_internal (Elemcount sizei) |
428 | 1873 { |
1204 | 1874 /* no `next' field; we use lcrecords */ |
665 | 1875 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei); |
1876 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, | |
1204 | 1877 unsigned long, |
1878 bits, num_longs); | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1879 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, bit_vector); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
1880 Lisp_Bit_Vector *p = XBIT_VECTOR (obj); |
428 | 1881 |
1882 bit_vector_length (p) = sizei; | |
1883 return p; | |
1884 } | |
1885 | |
1886 Lisp_Object | |
665 | 1887 make_bit_vector (Elemcount length, Lisp_Object bit) |
428 | 1888 { |
440 | 1889 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
665 | 1890 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length); |
428 | 1891 |
444 | 1892 CHECK_BIT (bit); |
1893 | |
1894 if (ZEROP (bit)) | |
428 | 1895 memset (p->bits, 0, num_longs * sizeof (long)); |
1896 else | |
1897 { | |
665 | 1898 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1); |
428 | 1899 memset (p->bits, ~0, num_longs * sizeof (long)); |
1900 /* But we have to make sure that the unused bits in the | |
1901 last long are 0, so that equal/hash is easy. */ | |
1902 if (bits_in_last) | |
1903 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; | |
1904 } | |
1905 | |
793 | 1906 return wrap_bit_vector (p); |
428 | 1907 } |
1908 | |
1909 Lisp_Object | |
665 | 1910 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length) |
428 | 1911 { |
665 | 1912 Elemcount i; |
428 | 1913 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
1914 | |
1915 for (i = 0; i < length; i++) | |
1916 set_bit_vector_bit (p, i, bytevec[i]); | |
1917 | |
793 | 1918 return wrap_bit_vector (p); |
428 | 1919 } |
1920 | |
1921 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /* | |
444 | 1922 Return a new bit vector of length LENGTH. with each bit set to BIT. |
1923 BIT must be one of the integers 0 or 1. See also the function `bit-vector'. | |
428 | 1924 */ |
444 | 1925 (length, bit)) |
428 | 1926 { |
1927 CONCHECK_NATNUM (length); | |
1928 | |
444 | 1929 return make_bit_vector (XINT (length), bit); |
428 | 1930 } |
1931 | |
1932 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /* | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1933 Return a newly created bit vector with specified ARGS as elements. |
428 | 1934 Any number of arguments, even zero arguments, are allowed. |
444 | 1935 Each argument must be one of the integers 0 or 1. |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1936 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1937 arguments: (&rest ARGS) |
428 | 1938 */ |
1939 (int nargs, Lisp_Object *args)) | |
1940 { | |
1941 int i; | |
1942 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs); | |
1943 | |
1944 for (i = 0; i < nargs; i++) | |
1945 { | |
1946 CHECK_BIT (args[i]); | |
1947 set_bit_vector_bit (p, i, !ZEROP (args[i])); | |
1948 } | |
1949 | |
793 | 1950 return wrap_bit_vector (p); |
428 | 1951 } |
1952 | |
1953 | |
1954 /************************************************************************/ | |
1955 /* Compiled-function allocation */ | |
1956 /************************************************************************/ | |
1957 | |
1958 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); | |
1959 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 | |
1960 | |
1961 static Lisp_Object | |
1962 make_compiled_function (void) | |
1963 { | |
1964 Lisp_Compiled_Function *f; | |
1965 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1966 ALLOC_FROB_BLOCK_LISP_OBJECT (compiled_function, Lisp_Compiled_Function, |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
1967 f, &lrecord_compiled_function); |
428 | 1968 |
1969 f->stack_depth = 0; | |
1970 f->specpdl_depth = 0; | |
1971 f->flags.documentationp = 0; | |
1972 f->flags.interactivep = 0; | |
1973 f->flags.domainp = 0; /* I18N3 */ | |
1974 f->instructions = Qzero; | |
1975 f->constants = Qzero; | |
1976 f->arglist = Qnil; | |
3092 | 1977 #ifdef NEW_GC |
1978 f->arguments = Qnil; | |
1979 #else /* not NEW_GC */ | |
1739 | 1980 f->args = NULL; |
3092 | 1981 #endif /* not NEW_GC */ |
1739 | 1982 f->max_args = f->min_args = f->args_in_array = 0; |
428 | 1983 f->doc_and_interactive = Qnil; |
1984 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
1985 f->annotated = Qnil; | |
1986 #endif | |
793 | 1987 return wrap_compiled_function (f); |
428 | 1988 } |
1989 | |
1990 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* | |
1991 Return a new compiled-function object. | |
1992 Note that, unlike all other emacs-lisp functions, calling this with five | |
1993 arguments is NOT the same as calling it with six arguments, the last of | |
1994 which is nil. If the INTERACTIVE arg is specified as nil, then that means | |
1995 that this function was defined with `(interactive)'. If the arg is not | |
1996 specified, then that means the function is not interactive. | |
1997 This is terrible behavior which is retained for compatibility with old | |
1998 `.elc' files which expect these semantics. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
1999 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2000 arguments: (ARGLIST INSTRUCTIONS CONSTANTS STACK-DEPTH &optional DOC-STRING INTERACTIVE) |
428 | 2001 */ |
2002 (int nargs, Lisp_Object *args)) | |
2003 { | |
2004 /* In a non-insane world this function would have this arglist... | |
2005 (arglist instructions constants stack_depth &optional doc_string interactive) | |
2006 */ | |
2007 Lisp_Object fun = make_compiled_function (); | |
2008 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
2009 | |
2010 Lisp_Object arglist = args[0]; | |
2011 Lisp_Object instructions = args[1]; | |
2012 Lisp_Object constants = args[2]; | |
2013 Lisp_Object stack_depth = args[3]; | |
2014 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; | |
2015 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; | |
2016 | |
2017 if (nargs < 4 || nargs > 6) | |
2018 return Fsignal (Qwrong_number_of_arguments, | |
2019 list2 (intern ("make-byte-code"), make_int (nargs))); | |
2020 | |
2021 /* Check for valid formal parameter list now, to allow us to use | |
2022 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */ | |
2023 { | |
814 | 2024 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
428 | 2025 { |
2026 CHECK_SYMBOL (symbol); | |
2027 if (EQ (symbol, Qt) || | |
2028 EQ (symbol, Qnil) || | |
2029 SYMBOL_IS_KEYWORD (symbol)) | |
563 | 2030 invalid_constant_2 |
428 | 2031 ("Invalid constant symbol in formal parameter list", |
2032 symbol, arglist); | |
2033 } | |
2034 } | |
2035 f->arglist = arglist; | |
2036 | |
2037 /* `instructions' is a string or a cons (string . int) for a | |
2038 lazy-loaded function. */ | |
2039 if (CONSP (instructions)) | |
2040 { | |
2041 CHECK_STRING (XCAR (instructions)); | |
2042 CHECK_INT (XCDR (instructions)); | |
2043 } | |
2044 else | |
2045 { | |
2046 CHECK_STRING (instructions); | |
2047 } | |
2048 f->instructions = instructions; | |
2049 | |
2050 if (!NILP (constants)) | |
2051 CHECK_VECTOR (constants); | |
2052 f->constants = constants; | |
2053 | |
2054 CHECK_NATNUM (stack_depth); | |
442 | 2055 f->stack_depth = (unsigned short) XINT (stack_depth); |
428 | 2056 |
2057 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
4923
8ee3c10d1ed5
remove old no-longer-useful kludgy compiled-fun annotations hack
Ben Wing <ben@xemacs.org>
parents:
4921
diff
changeset
|
2058 f->annotated = Vload_file_name_internal; |
428 | 2059 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ |
2060 | |
2061 /* doc_string may be nil, string, int, or a cons (string . int). | |
2062 interactive may be list or string (or unbound). */ | |
2063 f->doc_and_interactive = Qunbound; | |
2064 #ifdef I18N3 | |
2065 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0) | |
2066 f->doc_and_interactive = Vfile_domain; | |
2067 #endif | |
2068 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0) | |
2069 { | |
2070 f->doc_and_interactive | |
2071 = (UNBOUNDP (f->doc_and_interactive) ? interactive : | |
2072 Fcons (interactive, f->doc_and_interactive)); | |
2073 } | |
2074 if ((f->flags.documentationp = !NILP (doc_string)) != 0) | |
2075 { | |
2076 f->doc_and_interactive | |
2077 = (UNBOUNDP (f->doc_and_interactive) ? doc_string : | |
2078 Fcons (doc_string, f->doc_and_interactive)); | |
2079 } | |
2080 if (UNBOUNDP (f->doc_and_interactive)) | |
2081 f->doc_and_interactive = Qnil; | |
2082 | |
2083 return fun; | |
2084 } | |
2085 | |
2086 | |
2087 /************************************************************************/ | |
2088 /* Symbol allocation */ | |
2089 /************************************************************************/ | |
2090 | |
440 | 2091 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol); |
428 | 2092 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 |
2093 | |
2094 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* | |
2095 Return a newly allocated uninterned symbol whose name is NAME. | |
2096 Its value and function definition are void, and its property list is nil. | |
2097 */ | |
2098 (name)) | |
2099 { | |
440 | 2100 Lisp_Symbol *p; |
428 | 2101 |
2102 CHECK_STRING (name); | |
2103 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2104 ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol); |
793 | 2105 p->name = name; |
428 | 2106 p->plist = Qnil; |
2107 p->value = Qunbound; | |
2108 p->function = Qunbound; | |
2109 symbol_next (p) = 0; | |
793 | 2110 return wrap_symbol (p); |
428 | 2111 } |
2112 | |
2113 | |
2114 /************************************************************************/ | |
2115 /* Extent allocation */ | |
2116 /************************************************************************/ | |
2117 | |
2118 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); | |
2119 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 | |
2120 | |
2121 struct extent * | |
2122 allocate_extent (void) | |
2123 { | |
2124 struct extent *e; | |
2125 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2126 ALLOC_FROB_BLOCK_LISP_OBJECT (extent, struct extent, e, &lrecord_extent); |
428 | 2127 extent_object (e) = Qnil; |
2128 set_extent_start (e, -1); | |
2129 set_extent_end (e, -1); | |
2130 e->plist = Qnil; | |
2131 | |
2132 xzero (e->flags); | |
2133 | |
2134 extent_face (e) = Qnil; | |
2135 e->flags.end_open = 1; /* default is for endpoints to behave like markers */ | |
2136 e->flags.detachable = 1; | |
2137 | |
2138 return e; | |
2139 } | |
2140 | |
2141 | |
2142 /************************************************************************/ | |
2143 /* Event allocation */ | |
2144 /************************************************************************/ | |
2145 | |
440 | 2146 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event); |
428 | 2147 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 |
2148 | |
2149 Lisp_Object | |
2150 allocate_event (void) | |
2151 { | |
440 | 2152 Lisp_Event *e; |
2153 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2154 ALLOC_FROB_BLOCK_LISP_OBJECT (event, Lisp_Event, e, &lrecord_event); |
428 | 2155 |
793 | 2156 return wrap_event (e); |
428 | 2157 } |
2158 | |
1204 | 2159 #ifdef EVENT_DATA_AS_OBJECTS |
934 | 2160 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data); |
2161 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000 | |
2162 | |
2163 Lisp_Object | |
1204 | 2164 make_key_data (void) |
934 | 2165 { |
2166 Lisp_Key_Data *d; | |
2167 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2168 ALLOC_FROB_BLOCK_LISP_OBJECT (key_data, Lisp_Key_Data, d, |
3017 | 2169 &lrecord_key_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2170 zero_nonsized_lisp_object (wrap_key_data (d)); |
1204 | 2171 d->keysym = Qnil; |
2172 | |
2173 return wrap_key_data (d); | |
934 | 2174 } |
2175 | |
2176 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data); | |
2177 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000 | |
2178 | |
2179 Lisp_Object | |
1204 | 2180 make_button_data (void) |
934 | 2181 { |
2182 Lisp_Button_Data *d; | |
2183 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2184 ALLOC_FROB_BLOCK_LISP_OBJECT (button_data, Lisp_Button_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2185 &lrecord_button_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2186 zero_nonsized_lisp_object (wrap_button_data (d)); |
1204 | 2187 return wrap_button_data (d); |
934 | 2188 } |
2189 | |
2190 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data); | |
2191 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000 | |
2192 | |
2193 Lisp_Object | |
1204 | 2194 make_motion_data (void) |
934 | 2195 { |
2196 Lisp_Motion_Data *d; | |
2197 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2198 ALLOC_FROB_BLOCK_LISP_OBJECT (motion_data, Lisp_Motion_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2199 &lrecord_motion_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2200 zero_nonsized_lisp_object (wrap_motion_data (d)); |
934 | 2201 |
1204 | 2202 return wrap_motion_data (d); |
934 | 2203 } |
2204 | |
2205 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data); | |
2206 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000 | |
2207 | |
2208 Lisp_Object | |
1204 | 2209 make_process_data (void) |
934 | 2210 { |
2211 Lisp_Process_Data *d; | |
2212 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2213 ALLOC_FROB_BLOCK_LISP_OBJECT (process_data, Lisp_Process_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2214 &lrecord_process_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2215 zero_nonsized_lisp_object (wrap_process_data (d)); |
1204 | 2216 d->process = Qnil; |
2217 | |
2218 return wrap_process_data (d); | |
934 | 2219 } |
2220 | |
2221 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data); | |
2222 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000 | |
2223 | |
2224 Lisp_Object | |
1204 | 2225 make_timeout_data (void) |
934 | 2226 { |
2227 Lisp_Timeout_Data *d; | |
2228 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2229 ALLOC_FROB_BLOCK_LISP_OBJECT (timeout_data, Lisp_Timeout_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2230 &lrecord_timeout_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2231 zero_nonsized_lisp_object (wrap_timeout_data (d)); |
1204 | 2232 d->function = Qnil; |
2233 d->object = Qnil; | |
2234 | |
2235 return wrap_timeout_data (d); | |
934 | 2236 } |
2237 | |
2238 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data); | |
2239 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000 | |
2240 | |
2241 Lisp_Object | |
1204 | 2242 make_magic_data (void) |
934 | 2243 { |
2244 Lisp_Magic_Data *d; | |
2245 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2246 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_data, Lisp_Magic_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2247 &lrecord_magic_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2248 zero_nonsized_lisp_object (wrap_magic_data (d)); |
934 | 2249 |
1204 | 2250 return wrap_magic_data (d); |
934 | 2251 } |
2252 | |
2253 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data); | |
2254 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000 | |
2255 | |
2256 Lisp_Object | |
1204 | 2257 make_magic_eval_data (void) |
934 | 2258 { |
2259 Lisp_Magic_Eval_Data *d; | |
2260 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2261 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2262 &lrecord_magic_eval_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2263 zero_nonsized_lisp_object (wrap_magic_eval_data (d)); |
1204 | 2264 d->object = Qnil; |
2265 | |
2266 return wrap_magic_eval_data (d); | |
934 | 2267 } |
2268 | |
2269 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data); | |
2270 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000 | |
2271 | |
2272 Lisp_Object | |
1204 | 2273 make_eval_data (void) |
934 | 2274 { |
2275 Lisp_Eval_Data *d; | |
2276 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2277 ALLOC_FROB_BLOCK_LISP_OBJECT (eval_data, Lisp_Eval_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2278 &lrecord_eval_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2279 zero_nonsized_lisp_object (wrap_eval_data (d)); |
1204 | 2280 d->function = Qnil; |
2281 d->object = Qnil; | |
2282 | |
2283 return wrap_eval_data (d); | |
934 | 2284 } |
2285 | |
2286 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data); | |
2287 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000 | |
2288 | |
2289 Lisp_Object | |
1204 | 2290 make_misc_user_data (void) |
934 | 2291 { |
2292 Lisp_Misc_User_Data *d; | |
2293 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2294 ALLOC_FROB_BLOCK_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data, d, |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2295 &lrecord_misc_user_data); |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2296 zero_nonsized_lisp_object (wrap_misc_user_data (d)); |
1204 | 2297 d->function = Qnil; |
2298 d->object = Qnil; | |
2299 | |
2300 return wrap_misc_user_data (d); | |
934 | 2301 } |
1204 | 2302 |
2303 #endif /* EVENT_DATA_AS_OBJECTS */ | |
428 | 2304 |
2305 /************************************************************************/ | |
2306 /* Marker allocation */ | |
2307 /************************************************************************/ | |
2308 | |
440 | 2309 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker); |
428 | 2310 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 |
2311 | |
2312 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* | |
2313 Return a new marker which does not point at any place. | |
2314 */ | |
2315 ()) | |
2316 { | |
440 | 2317 Lisp_Marker *p; |
2318 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2319 ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, &lrecord_marker); |
428 | 2320 p->buffer = 0; |
665 | 2321 p->membpos = 0; |
428 | 2322 marker_next (p) = 0; |
2323 marker_prev (p) = 0; | |
2324 p->insertion_type = 0; | |
793 | 2325 return wrap_marker (p); |
428 | 2326 } |
2327 | |
2328 Lisp_Object | |
2329 noseeum_make_marker (void) | |
2330 { | |
440 | 2331 Lisp_Marker *p; |
2332 | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2333 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
2334 &lrecord_marker); |
428 | 2335 p->buffer = 0; |
665 | 2336 p->membpos = 0; |
428 | 2337 marker_next (p) = 0; |
2338 marker_prev (p) = 0; | |
2339 p->insertion_type = 0; | |
793 | 2340 return wrap_marker (p); |
428 | 2341 } |
2342 | |
2343 | |
2344 /************************************************************************/ | |
2345 /* String allocation */ | |
2346 /************************************************************************/ | |
2347 | |
2348 /* The data for "short" strings generally resides inside of structs of type | |
2349 string_chars_block. The Lisp_String structure is allocated just like any | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2350 other frob-block lrecord, and these are freelisted when they get garbage |
1204 | 2351 collected. The data for short strings get compacted, but the data for |
2352 large strings do not. | |
428 | 2353 |
2354 Previously Lisp_String structures were relocated, but this caused a lot | |
2355 of bus-errors because the C code didn't include enough GCPRO's for | |
2356 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so | |
2357 that the reference would get relocated). | |
2358 | |
2359 This new method makes things somewhat bigger, but it is MUCH safer. */ | |
2360 | |
438 | 2361 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String); |
428 | 2362 /* strings are used and freed quite often */ |
2363 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ | |
2364 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 | |
2365 | |
2366 static Lisp_Object | |
2367 mark_string (Lisp_Object obj) | |
2368 { | |
793 | 2369 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj)))) |
2370 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj))); | |
2371 return XSTRING_PLIST (obj); | |
428 | 2372 } |
2373 | |
2374 static int | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2375 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2376 int foldcase) |
428 | 2377 { |
2378 Bytecount len; | |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2379 if (foldcase) |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2380 return !lisp_strcasecmp_i18n (obj1, obj2); |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2381 else |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2382 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
2383 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); |
428 | 2384 } |
2385 | |
1204 | 2386 static const struct memory_description string_description[] = { |
3092 | 2387 #ifdef NEW_GC |
2388 { XD_LISP_OBJECT, offsetof (Lisp_String, data_object) }, | |
2389 #else /* not NEW_GC */ | |
793 | 2390 { XD_BYTECOUNT, offsetof (Lisp_String, size_) }, |
2391 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) }, | |
3092 | 2392 #endif /* not NEW_GC */ |
440 | 2393 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, |
428 | 2394 { XD_END } |
2395 }; | |
2396 | |
442 | 2397 /* We store the string's extent info as the first element of the string's |
2398 property list; and the string's MODIFF as the first or second element | |
2399 of the string's property list (depending on whether the extent info | |
2400 is present), but only if the string has been modified. This is ugly | |
2401 but it reduces the memory allocated for the string in the vast | |
2402 majority of cases, where the string is never modified and has no | |
2403 extent info. | |
2404 | |
2405 #### This means you can't use an int as a key in a string's plist. */ | |
2406 | |
2407 static Lisp_Object * | |
2408 string_plist_ptr (Lisp_Object string) | |
2409 { | |
793 | 2410 Lisp_Object *ptr = &XSTRING_PLIST (string); |
442 | 2411 |
2412 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
2413 ptr = &XCDR (*ptr); | |
2414 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
2415 ptr = &XCDR (*ptr); | |
2416 return ptr; | |
2417 } | |
2418 | |
2419 static Lisp_Object | |
2420 string_getprop (Lisp_Object string, Lisp_Object property) | |
2421 { | |
2422 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME); | |
2423 } | |
2424 | |
2425 static int | |
2426 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value) | |
2427 { | |
2428 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME); | |
2429 return 1; | |
2430 } | |
2431 | |
2432 static int | |
2433 string_remprop (Lisp_Object string, Lisp_Object property) | |
2434 { | |
2435 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME); | |
2436 } | |
2437 | |
2438 static Lisp_Object | |
2439 string_plist (Lisp_Object string) | |
2440 { | |
2441 return *string_plist_ptr (string); | |
2442 } | |
2443 | |
3263 | 2444 #ifndef NEW_GC |
442 | 2445 /* No `finalize', or `hash' methods. |
2446 internal_hash() already knows how to hash strings and finalization | |
2447 is done with the ADDITIONAL_FREE_string macro, which is the | |
2448 standard way to do finalization when using | |
2449 SWEEP_FIXED_TYPE_BLOCK(). */ | |
2720 | 2450 |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2451 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("string", string, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2452 mark_string, print_string, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2453 0, string_equal, 0, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2454 string_description, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2455 Lisp_String); |
3263 | 2456 #endif /* not NEW_GC */ |
2720 | 2457 |
3092 | 2458 #ifdef NEW_GC |
2459 #define STRING_FULLSIZE(size) \ | |
2460 ALIGN_SIZE (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_String_Direct_Data, Lisp_Object, data, (size) + 1), sizeof (Lisp_Object *)); | |
2461 #else /* not NEW_GC */ | |
428 | 2462 /* String blocks contain this many useful bytes. */ |
2463 #define STRING_CHARS_BLOCK_SIZE \ | |
814 | 2464 ((Bytecount) (8192 - MALLOC_OVERHEAD - \ |
2465 ((2 * sizeof (struct string_chars_block *)) \ | |
2466 + sizeof (EMACS_INT)))) | |
428 | 2467 /* Block header for small strings. */ |
2468 struct string_chars_block | |
2469 { | |
2470 EMACS_INT pos; | |
2471 struct string_chars_block *next; | |
2472 struct string_chars_block *prev; | |
2473 /* Contents of string_chars_block->string_chars are interleaved | |
2474 string_chars structures (see below) and the actual string data */ | |
2475 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE]; | |
2476 }; | |
2477 | |
2478 static struct string_chars_block *first_string_chars_block; | |
2479 static struct string_chars_block *current_string_chars_block; | |
2480 | |
2481 /* If SIZE is the length of a string, this returns how many bytes | |
2482 * the string occupies in string_chars_block->string_chars | |
2483 * (including alignment padding). | |
2484 */ | |
438 | 2485 #define STRING_FULLSIZE(size) \ |
826 | 2486 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *) |
428 | 2487 |
2488 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE) | |
2489 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size))) | |
2490 | |
454 | 2491 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL) |
2492 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL)) | |
3092 | 2493 #endif /* not NEW_GC */ |
454 | 2494 |
3263 | 2495 #ifdef NEW_GC |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2496 DEFINE_DUMPABLE_LISP_OBJECT ("string", string, mark_string, print_string, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2497 0, string_equal, 0, |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
2498 string_description, Lisp_String); |
3092 | 2499 |
2500 | |
2501 static const struct memory_description string_direct_data_description[] = { | |
3514 | 2502 { XD_BYTECOUNT, offsetof (Lisp_String_Direct_Data, size) }, |
3092 | 2503 { XD_END } |
2504 }; | |
2505 | |
2506 static Bytecount | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2507 size_string_direct_data (Lisp_Object obj) |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2508 { |
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2509 return STRING_FULLSIZE (XSTRING_DIRECT_DATA (obj)->size); |
3092 | 2510 } |
2511 | |
2512 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2513 DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("string-direct-data", |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2514 string_direct_data, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2515 0, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2516 string_direct_data_description, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2517 size_string_direct_data, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2518 Lisp_String_Direct_Data); |
3092 | 2519 |
2520 | |
2521 static const struct memory_description string_indirect_data_description[] = { | |
2522 { XD_BYTECOUNT, offsetof (Lisp_String_Indirect_Data, size) }, | |
2523 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String_Indirect_Data, data), | |
2524 XD_INDIRECT(0, 1) }, | |
2525 { XD_END } | |
2526 }; | |
2527 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2528 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("string-indirect-data", |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2529 string_indirect_data, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2530 0, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2531 string_indirect_data_description, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2532 Lisp_String_Indirect_Data); |
3092 | 2533 #endif /* NEW_GC */ |
2720 | 2534 |
3092 | 2535 #ifndef NEW_GC |
428 | 2536 struct string_chars |
2537 { | |
438 | 2538 Lisp_String *string; |
428 | 2539 unsigned char chars[1]; |
2540 }; | |
2541 | |
2542 struct unused_string_chars | |
2543 { | |
438 | 2544 Lisp_String *string; |
428 | 2545 EMACS_INT fullsize; |
2546 }; | |
2547 | |
2548 static void | |
2549 init_string_chars_alloc (void) | |
2550 { | |
2551 first_string_chars_block = xnew (struct string_chars_block); | |
2552 first_string_chars_block->prev = 0; | |
2553 first_string_chars_block->next = 0; | |
2554 first_string_chars_block->pos = 0; | |
2555 current_string_chars_block = first_string_chars_block; | |
2556 } | |
2557 | |
1550 | 2558 static Ibyte * |
2559 allocate_big_string_chars (Bytecount length) | |
2560 { | |
2561 Ibyte *p = xnew_array (Ibyte, length); | |
2562 INCREMENT_CONS_COUNTER (length, "string chars"); | |
2563 return p; | |
2564 } | |
2565 | |
428 | 2566 static struct string_chars * |
793 | 2567 allocate_string_chars_struct (Lisp_Object string_it_goes_with, |
814 | 2568 Bytecount fullsize) |
428 | 2569 { |
2570 struct string_chars *s_chars; | |
2571 | |
438 | 2572 if (fullsize <= |
2573 (countof (current_string_chars_block->string_chars) | |
2574 - current_string_chars_block->pos)) | |
428 | 2575 { |
2576 /* This string can fit in the current string chars block */ | |
2577 s_chars = (struct string_chars *) | |
2578 (current_string_chars_block->string_chars | |
2579 + current_string_chars_block->pos); | |
2580 current_string_chars_block->pos += fullsize; | |
2581 } | |
2582 else | |
2583 { | |
2584 /* Make a new current string chars block */ | |
2585 struct string_chars_block *new_scb = xnew (struct string_chars_block); | |
2586 | |
2587 current_string_chars_block->next = new_scb; | |
2588 new_scb->prev = current_string_chars_block; | |
2589 new_scb->next = 0; | |
2590 current_string_chars_block = new_scb; | |
2591 new_scb->pos = fullsize; | |
2592 s_chars = (struct string_chars *) | |
2593 current_string_chars_block->string_chars; | |
2594 } | |
2595 | |
793 | 2596 s_chars->string = XSTRING (string_it_goes_with); |
428 | 2597 |
2598 INCREMENT_CONS_COUNTER (fullsize, "string chars"); | |
2599 | |
2600 return s_chars; | |
2601 } | |
3092 | 2602 #endif /* not NEW_GC */ |
428 | 2603 |
771 | 2604 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN |
2605 void | |
2606 sledgehammer_check_ascii_begin (Lisp_Object str) | |
2607 { | |
2608 Bytecount i; | |
2609 | |
2610 for (i = 0; i < XSTRING_LENGTH (str); i++) | |
2611 { | |
826 | 2612 if (!byte_ascii_p (string_byte (str, i))) |
771 | 2613 break; |
2614 } | |
2615 | |
2616 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) || | |
2617 (i > MAX_STRING_ASCII_BEGIN && | |
2618 (Bytecount) XSTRING_ASCII_BEGIN (str) == | |
2619 (Bytecount) MAX_STRING_ASCII_BEGIN)); | |
2620 } | |
2621 #endif | |
2622 | |
2623 /* You do NOT want to be calling this! (And if you do, you must call | |
851 | 2624 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA () |
771 | 2625 instead and then call make_string() like the rest of the world. */ |
2626 | |
428 | 2627 Lisp_Object |
2628 make_uninit_string (Bytecount length) | |
2629 { | |
438 | 2630 Lisp_String *s; |
814 | 2631 Bytecount fullsize = STRING_FULLSIZE (length); |
428 | 2632 |
438 | 2633 assert (length >= 0 && fullsize > 0); |
428 | 2634 |
3263 | 2635 #ifdef NEW_GC |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
2636 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); |
3263 | 2637 #else /* not NEW_GC */ |
428 | 2638 /* Allocate the string header */ |
438 | 2639 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
793 | 2640 xzero (*s); |
771 | 2641 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
3263 | 2642 #endif /* not NEW_GC */ |
2720 | 2643 |
3063 | 2644 /* The above allocations set the UID field, which overlaps with the |
2645 ascii-length field, to some non-zero value. We need to zero it. */ | |
2646 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0); | |
2647 | |
3092 | 2648 #ifdef NEW_GC |
3304 | 2649 set_lispstringp_direct (s); |
3092 | 2650 STRING_DATA_OBJECT (s) = |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2651 alloc_sized_lrecord (fullsize, &lrecord_string_direct_data); |
3092 | 2652 #else /* not NEW_GC */ |
826 | 2653 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) |
2720 | 2654 ? allocate_big_string_chars (length + 1) |
2655 : allocate_string_chars_struct (wrap_string (s), | |
2656 fullsize)->chars); | |
3092 | 2657 #endif /* not NEW_GC */ |
438 | 2658 |
826 | 2659 set_lispstringp_length (s, length); |
428 | 2660 s->plist = Qnil; |
793 | 2661 set_string_byte (wrap_string (s), length, 0); |
2662 | |
2663 return wrap_string (s); | |
428 | 2664 } |
2665 | |
2666 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
2667 static void verify_string_chars_integrity (void); | |
2668 #endif | |
2669 | |
2670 /* Resize the string S so that DELTA bytes can be inserted starting | |
2671 at POS. If DELTA < 0, it means deletion starting at POS. If | |
2672 POS < 0, resize the string but don't copy any characters. Use | |
2673 this if you're planning on completely overwriting the string. | |
2674 */ | |
2675 | |
2676 void | |
793 | 2677 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) |
428 | 2678 { |
3092 | 2679 #ifdef NEW_GC |
2680 Bytecount newfullsize, len; | |
2681 #else /* not NEW_GC */ | |
438 | 2682 Bytecount oldfullsize, newfullsize; |
3092 | 2683 #endif /* not NEW_GC */ |
428 | 2684 #ifdef VERIFY_STRING_CHARS_INTEGRITY |
2685 verify_string_chars_integrity (); | |
2686 #endif | |
800 | 2687 #ifdef ERROR_CHECK_TEXT |
428 | 2688 if (pos >= 0) |
2689 { | |
793 | 2690 assert (pos <= XSTRING_LENGTH (s)); |
428 | 2691 if (delta < 0) |
793 | 2692 assert (pos + (-delta) <= XSTRING_LENGTH (s)); |
428 | 2693 } |
2694 else | |
2695 { | |
2696 if (delta < 0) | |
793 | 2697 assert ((-delta) <= XSTRING_LENGTH (s)); |
428 | 2698 } |
800 | 2699 #endif /* ERROR_CHECK_TEXT */ |
428 | 2700 |
2701 if (delta == 0) | |
2702 /* simplest case: no size change. */ | |
2703 return; | |
438 | 2704 |
2705 if (pos >= 0 && delta < 0) | |
2706 /* If DELTA < 0, the functions below will delete the characters | |
2707 before POS. We want to delete characters *after* POS, however, | |
2708 so convert this to the appropriate form. */ | |
2709 pos += -delta; | |
2710 | |
3092 | 2711 #ifdef NEW_GC |
2712 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
2713 | |
2714 len = XSTRING_LENGTH (s) + 1 - pos; | |
2715 | |
2716 if (delta < 0 && pos >= 0) | |
2717 memmove (XSTRING_DATA (s) + pos + delta, | |
2718 XSTRING_DATA (s) + pos, len); | |
2719 | |
2720 XSTRING_DATA_OBJECT (s) = | |
2721 wrap_string_direct_data (mc_realloc (XPNTR (XSTRING_DATA_OBJECT (s)), | |
2722 newfullsize)); | |
2723 if (delta > 0 && pos >= 0) | |
2724 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, | |
2725 len); | |
2726 | |
3263 | 2727 #else /* not NEW_GC */ |
793 | 2728 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s)); |
2729 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
438 | 2730 |
2731 if (BIG_STRING_FULLSIZE_P (oldfullsize)) | |
428 | 2732 { |
438 | 2733 if (BIG_STRING_FULLSIZE_P (newfullsize)) |
428 | 2734 { |
440 | 2735 /* Both strings are big. We can just realloc(). |
2736 But careful! If the string is shrinking, we have to | |
2737 memmove() _before_ realloc(), and if growing, we have to | |
2738 memmove() _after_ realloc() - otherwise the access is | |
2739 illegal, and we might crash. */ | |
793 | 2740 Bytecount len = XSTRING_LENGTH (s) + 1 - pos; |
440 | 2741 |
2742 if (delta < 0 && pos >= 0) | |
793 | 2743 memmove (XSTRING_DATA (s) + pos + delta, |
2744 XSTRING_DATA (s) + pos, len); | |
2745 XSET_STRING_DATA | |
867 | 2746 (s, (Ibyte *) xrealloc (XSTRING_DATA (s), |
793 | 2747 XSTRING_LENGTH (s) + delta + 1)); |
440 | 2748 if (delta > 0 && pos >= 0) |
793 | 2749 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, |
2750 len); | |
1550 | 2751 /* Bump the cons counter. |
2752 Conservative; Martin let the increment be delta. */ | |
2753 INCREMENT_CONS_COUNTER (newfullsize, "string chars"); | |
428 | 2754 } |
438 | 2755 else /* String has been demoted from BIG_STRING. */ |
428 | 2756 { |
867 | 2757 Ibyte *new_data = |
438 | 2758 allocate_string_chars_struct (s, newfullsize)->chars; |
867 | 2759 Ibyte *old_data = XSTRING_DATA (s); |
438 | 2760 |
2761 if (pos >= 0) | |
2762 { | |
2763 memcpy (new_data, old_data, pos); | |
2764 memcpy (new_data + pos + delta, old_data + pos, | |
793 | 2765 XSTRING_LENGTH (s) + 1 - pos); |
438 | 2766 } |
793 | 2767 XSET_STRING_DATA (s, new_data); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
2768 xfree (old_data); |
438 | 2769 } |
2770 } | |
2771 else /* old string is small */ | |
2772 { | |
2773 if (oldfullsize == newfullsize) | |
2774 { | |
2775 /* special case; size change but the necessary | |
2776 allocation size won't change (up or down; code | |
2777 somewhere depends on there not being any unused | |
2778 allocation space, modulo any alignment | |
2779 constraints). */ | |
428 | 2780 if (pos >= 0) |
2781 { | |
867 | 2782 Ibyte *addroff = pos + XSTRING_DATA (s); |
428 | 2783 |
2784 memmove (addroff + delta, addroff, | |
2785 /* +1 due to zero-termination. */ | |
793 | 2786 XSTRING_LENGTH (s) + 1 - pos); |
428 | 2787 } |
2788 } | |
2789 else | |
2790 { | |
867 | 2791 Ibyte *old_data = XSTRING_DATA (s); |
2792 Ibyte *new_data = | |
438 | 2793 BIG_STRING_FULLSIZE_P (newfullsize) |
1550 | 2794 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1) |
438 | 2795 : allocate_string_chars_struct (s, newfullsize)->chars; |
2796 | |
428 | 2797 if (pos >= 0) |
2798 { | |
438 | 2799 memcpy (new_data, old_data, pos); |
2800 memcpy (new_data + pos + delta, old_data + pos, | |
793 | 2801 XSTRING_LENGTH (s) + 1 - pos); |
428 | 2802 } |
793 | 2803 XSET_STRING_DATA (s, new_data); |
438 | 2804 |
4776
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2805 if (!DUMPEDP (old_data)) /* Can't free dumped data. */ |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2806 { |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2807 /* We need to mark this chunk of the string_chars_block |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2808 as unused so that compact_string_chars() doesn't |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2809 freak. */ |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2810 struct string_chars *old_s_chars = (struct string_chars *) |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2811 ((char *) old_data - offsetof (struct string_chars, chars)); |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2812 /* Sanity check to make sure we aren't hosed by strange |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2813 alignment/padding. */ |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2814 assert (old_s_chars->string == XSTRING (s)); |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2815 MARK_STRING_CHARS_AS_FREE (old_s_chars); |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2816 ((struct unused_string_chars *) old_s_chars)->fullsize = |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2817 oldfullsize; |
73e8632018ad
Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents:
4735
diff
changeset
|
2818 } |
428 | 2819 } |
438 | 2820 } |
3092 | 2821 #endif /* not NEW_GC */ |
438 | 2822 |
793 | 2823 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); |
438 | 2824 /* If pos < 0, the string won't be zero-terminated. |
2825 Terminate now just to make sure. */ | |
793 | 2826 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0'; |
438 | 2827 |
2828 if (pos >= 0) | |
793 | 2829 /* We also have to adjust all of the extent indices after the |
2830 place we did the change. We say "pos - 1" because | |
2831 adjust_extents() is exclusive of the starting position | |
2832 passed to it. */ | |
2833 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta); | |
428 | 2834 |
2835 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
2836 verify_string_chars_integrity (); | |
2837 #endif | |
2838 } | |
2839 | |
2840 #ifdef MULE | |
2841 | |
771 | 2842 /* WARNING: If you modify an existing string, you must call |
2843 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */ | |
428 | 2844 void |
867 | 2845 set_string_char (Lisp_Object s, Charcount i, Ichar c) |
428 | 2846 { |
867 | 2847 Ibyte newstr[MAX_ICHAR_LEN]; |
771 | 2848 Bytecount bytoff = string_index_char_to_byte (s, i); |
867 | 2849 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff); |
2850 Bytecount newlen = set_itext_ichar (newstr, c); | |
428 | 2851 |
793 | 2852 sledgehammer_check_ascii_begin (s); |
428 | 2853 if (oldlen != newlen) |
2854 resize_string (s, bytoff, newlen - oldlen); | |
793 | 2855 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */ |
2856 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen); | |
771 | 2857 if (oldlen != newlen) |
2858 { | |
793 | 2859 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s)) |
771 | 2860 /* Everything starting with the new char is no longer part of |
2861 ascii_begin */ | |
793 | 2862 XSET_STRING_ASCII_BEGIN (s, i); |
2863 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s)) | |
771 | 2864 /* We've extended ascii_begin, and we have to figure out how much by */ |
2865 { | |
2866 Bytecount j; | |
814 | 2867 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++) |
771 | 2868 { |
826 | 2869 if (!byte_ascii_p (XSTRING_DATA (s)[j])) |
771 | 2870 break; |
2871 } | |
814 | 2872 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN)); |
771 | 2873 } |
2874 } | |
793 | 2875 sledgehammer_check_ascii_begin (s); |
428 | 2876 } |
2877 | |
2878 #endif /* MULE */ | |
2879 | |
2880 DEFUN ("make-string", Fmake_string, 2, 2, 0, /* | |
444 | 2881 Return a new string consisting of LENGTH copies of CHARACTER. |
2882 LENGTH must be a non-negative integer. | |
428 | 2883 */ |
444 | 2884 (length, character)) |
428 | 2885 { |
2886 CHECK_NATNUM (length); | |
444 | 2887 CHECK_CHAR_COERCE_INT (character); |
428 | 2888 { |
867 | 2889 Ibyte init_str[MAX_ICHAR_LEN]; |
2890 int len = set_itext_ichar (init_str, XCHAR (character)); | |
428 | 2891 Lisp_Object val = make_uninit_string (len * XINT (length)); |
2892 | |
2893 if (len == 1) | |
771 | 2894 { |
2895 /* Optimize the single-byte case */ | |
2896 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val)); | |
793 | 2897 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN, |
2898 len * XINT (length))); | |
771 | 2899 } |
428 | 2900 else |
2901 { | |
647 | 2902 EMACS_INT i; |
867 | 2903 Ibyte *ptr = XSTRING_DATA (val); |
428 | 2904 |
2905 for (i = XINT (length); i; i--) | |
2906 { | |
867 | 2907 Ibyte *init_ptr = init_str; |
428 | 2908 switch (len) |
2909 { | |
2910 case 4: *ptr++ = *init_ptr++; | |
2911 case 3: *ptr++ = *init_ptr++; | |
2912 case 2: *ptr++ = *init_ptr++; | |
2913 case 1: *ptr++ = *init_ptr++; | |
2914 } | |
2915 } | |
2916 } | |
771 | 2917 sledgehammer_check_ascii_begin (val); |
428 | 2918 return val; |
2919 } | |
2920 } | |
2921 | |
2922 DEFUN ("string", Fstring, 0, MANY, 0, /* | |
2923 Concatenate all the argument characters and make the result a string. | |
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2924 |
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3514
diff
changeset
|
2925 arguments: (&rest ARGS) |
428 | 2926 */ |
2927 (int nargs, Lisp_Object *args)) | |
2928 { | |
2367 | 2929 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN); |
867 | 2930 Ibyte *p = storage; |
428 | 2931 |
2932 for (; nargs; nargs--, args++) | |
2933 { | |
2934 Lisp_Object lisp_char = *args; | |
2935 CHECK_CHAR_COERCE_INT (lisp_char); | |
867 | 2936 p += set_itext_ichar (p, XCHAR (lisp_char)); |
428 | 2937 } |
2938 return make_string (storage, p - storage); | |
2939 } | |
2940 | |
771 | 2941 /* Initialize the ascii_begin member of a string to the correct value. */ |
2942 | |
2943 void | |
2944 init_string_ascii_begin (Lisp_Object string) | |
2945 { | |
2946 #ifdef MULE | |
2947 int i; | |
2948 Bytecount length = XSTRING_LENGTH (string); | |
867 | 2949 Ibyte *contents = XSTRING_DATA (string); |
771 | 2950 |
2951 for (i = 0; i < length; i++) | |
2952 { | |
826 | 2953 if (!byte_ascii_p (contents[i])) |
771 | 2954 break; |
2955 } | |
793 | 2956 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN)); |
771 | 2957 #else |
793 | 2958 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string), |
2959 MAX_STRING_ASCII_BEGIN)); | |
771 | 2960 #endif |
2961 sledgehammer_check_ascii_begin (string); | |
2962 } | |
428 | 2963 |
2964 /* Take some raw memory, which MUST already be in internal format, | |
2965 and package it up into a Lisp string. */ | |
2966 Lisp_Object | |
867 | 2967 make_string (const Ibyte *contents, Bytecount length) |
428 | 2968 { |
2969 Lisp_Object val; | |
2970 | |
2971 /* Make sure we find out about bad make_string's when they happen */ | |
800 | 2972 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
428 | 2973 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
2974 #endif | |
2975 | |
2976 val = make_uninit_string (length); | |
2977 memcpy (XSTRING_DATA (val), contents, length); | |
771 | 2978 init_string_ascii_begin (val); |
2979 sledgehammer_check_ascii_begin (val); | |
428 | 2980 return val; |
2981 } | |
2982 | |
2983 /* Take some raw memory, encoded in some external data format, | |
2984 and convert it into a Lisp string. */ | |
2985 Lisp_Object | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2986 make_extstring (const Extbyte *contents, EMACS_INT length, |
440 | 2987 Lisp_Object coding_system) |
428 | 2988 { |
440 | 2989 Lisp_Object string; |
2990 TO_INTERNAL_FORMAT (DATA, (contents, length), | |
2991 LISP_STRING, string, | |
2992 coding_system); | |
2993 return string; | |
428 | 2994 } |
2995 | |
2996 Lisp_Object | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2997 build_istring (const Ibyte *str) |
771 | 2998 { |
2999 /* Some strlen's crash and burn if passed null. */ | |
814 | 3000 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0)); |
771 | 3001 } |
3002 | |
3003 Lisp_Object | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3004 build_cistring (const CIbyte *str) |
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3005 { |
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3006 return build_istring ((const Ibyte *) str); |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3007 } |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3008 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3009 Lisp_Object |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3010 build_ascstring (const Ascbyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3011 { |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3012 ASSERT_ASCTEXT_ASCII (str); |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3013 return build_istring ((const Ibyte *) str); |
428 | 3014 } |
3015 | |
3016 Lisp_Object | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3017 build_extstring (const Extbyte *str, Lisp_Object coding_system) |
428 | 3018 { |
3019 /* Some strlen's crash and burn if passed null. */ | |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3020 return make_extstring ((const Extbyte *) str, |
2367 | 3021 (str ? dfc_external_data_len (str, coding_system) : |
3022 0), | |
440 | 3023 coding_system); |
428 | 3024 } |
3025 | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3026 /* Build a string whose content is a translatable message, and translate |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3027 the message according to the current language environment. */ |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3028 |
428 | 3029 Lisp_Object |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3030 build_msg_istring (const Ibyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3031 { |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3032 return build_istring (IGETTEXT (str)); |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3033 } |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3034 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3035 /* Build a string whose content is a translatable message, and translate |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3036 the message according to the current language environment. */ |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3037 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3038 Lisp_Object |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3039 build_msg_cistring (const CIbyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3040 { |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3041 return build_msg_istring ((const Ibyte *) str); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3042 } |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3043 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3044 /* Build a string whose content is a translatable message, and translate |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3045 the message according to the current language environment. |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3046 String must be pure-ASCII, and when compiled with error-checking, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3047 an abort will have if not pure-ASCII. */ |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3048 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3049 Lisp_Object |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3050 build_msg_ascstring (const Ascbyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3051 { |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3052 ASSERT_ASCTEXT_ASCII (str); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3053 return build_msg_istring ((const Ibyte *) str); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3054 } |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3055 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3056 /* Build a string whose content is a translatable message, but don't |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3057 translate the message immediately. Perhaps do something else instead, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3058 such as put a property on the string indicating that it needs to be |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3059 translated. |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3060 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3061 This is useful for strings that are built at dump time or init time, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3062 rather than on-the-fly when the current language environment is set |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3063 properly. */ |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3064 |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3065 Lisp_Object |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3066 build_defer_istring (const Ibyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3067 { |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
3068 Lisp_Object retval = build_istring ((Ibyte *) str); |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3069 /* Possibly do something to the return value */ |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3070 return retval; |
771 | 3071 } |
3072 | |
428 | 3073 Lisp_Object |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3074 build_defer_cistring (const CIbyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3075 { |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3076 return build_defer_istring ((Ibyte *) str); |
771 | 3077 } |
3078 | |
3079 Lisp_Object | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3080 build_defer_ascstring (const Ascbyte *str) |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3081 { |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3082 ASSERT_ASCTEXT_ASCII (str); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3083 return build_defer_istring ((Ibyte *) str); |
428 | 3084 } |
3085 | |
3086 Lisp_Object | |
867 | 3087 make_string_nocopy (const Ibyte *contents, Bytecount length) |
428 | 3088 { |
438 | 3089 Lisp_String *s; |
428 | 3090 Lisp_Object val; |
3091 | |
3092 /* Make sure we find out about bad make_string_nocopy's when they happen */ | |
800 | 3093 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
428 | 3094 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
3095 #endif | |
3096 | |
3263 | 3097 #ifdef NEW_GC |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3098 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); |
2720 | 3099 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get |
3100 collected and static data is tried to | |
3101 be freed. */ | |
3263 | 3102 #else /* not NEW_GC */ |
428 | 3103 /* Allocate the string header */ |
438 | 3104 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
771 | 3105 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
3106 SET_C_READONLY_RECORD_HEADER (&s->u.lheader); | |
3263 | 3107 #endif /* not NEW_GC */ |
3063 | 3108 /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in |
3109 init_string_ascii_begin(). */ | |
428 | 3110 s->plist = Qnil; |
3092 | 3111 #ifdef NEW_GC |
3112 set_lispstringp_indirect (s); | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3113 STRING_DATA_OBJECT (s) = ALLOC_NORMAL_LISP_OBJECT (string_indirect_data); |
3092 | 3114 XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents; |
3115 XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length; | |
3116 #else /* not NEW_GC */ | |
867 | 3117 set_lispstringp_data (s, (Ibyte *) contents); |
826 | 3118 set_lispstringp_length (s, length); |
3092 | 3119 #endif /* not NEW_GC */ |
793 | 3120 val = wrap_string (s); |
771 | 3121 init_string_ascii_begin (val); |
3122 sledgehammer_check_ascii_begin (val); | |
3123 | |
428 | 3124 return val; |
3125 } | |
3126 | |
3127 | |
3263 | 3128 #ifndef NEW_GC |
428 | 3129 /************************************************************************/ |
3130 /* lcrecord lists */ | |
3131 /************************************************************************/ | |
3132 | |
3133 /* Lcrecord lists are used to manage the allocation of particular | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3134 sorts of lcrecords, to avoid calling ALLOC_NORMAL_LISP_OBJECT() (and thus |
428 | 3135 malloc() and garbage-collection junk) as much as possible. |
3136 It is similar to the Blocktype class. | |
3137 | |
1204 | 3138 See detailed comment in lcrecord.h. |
3139 */ | |
3140 | |
3141 const struct memory_description free_description[] = { | |
2551 | 3142 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 }, |
1204 | 3143 XD_FLAG_FREE_LISP_OBJECT }, |
3144 { XD_END } | |
3145 }; | |
3146 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3147 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("free", free, 0, free_description, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3148 struct free_lcrecord_header); |
1204 | 3149 |
3150 const struct memory_description lcrecord_list_description[] = { | |
2551 | 3151 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 }, |
1204 | 3152 XD_FLAG_FREE_LISP_OBJECT }, |
3153 { XD_END } | |
3154 }; | |
428 | 3155 |
3156 static Lisp_Object | |
3157 mark_lcrecord_list (Lisp_Object obj) | |
3158 { | |
3159 struct lcrecord_list *list = XLCRECORD_LIST (obj); | |
3160 Lisp_Object chain = list->free; | |
3161 | |
3162 while (!NILP (chain)) | |
3163 { | |
3164 struct lrecord_header *lheader = XRECORD_LHEADER (chain); | |
3165 struct free_lcrecord_header *free_header = | |
3166 (struct free_lcrecord_header *) lheader; | |
3167 | |
442 | 3168 gc_checking_assert |
3169 (/* There should be no other pointers to the free list. */ | |
3170 ! MARKED_RECORD_HEADER_P (lheader) | |
3171 && | |
3172 /* Only lcrecords should be here. */ | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3173 ! list->implementation->frob_block_p |
442 | 3174 && |
3175 /* Only free lcrecords should be here. */ | |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3176 lheader->free |
442 | 3177 && |
3178 /* The type of the lcrecord must be right. */ | |
1204 | 3179 lheader->type == lrecord_type_free |
442 | 3180 && |
3181 /* So must the size. */ | |
1204 | 3182 (list->implementation->static_size == 0 || |
3183 list->implementation->static_size == list->size) | |
442 | 3184 ); |
428 | 3185 |
3186 MARK_RECORD_HEADER (lheader); | |
3187 chain = free_header->chain; | |
3188 } | |
3189 | |
3190 return Qnil; | |
3191 } | |
3192 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3193 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("lcrecord-list", lcrecord_list, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3194 mark_lcrecord_list, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3195 lcrecord_list_description, |
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3196 struct lcrecord_list); |
934 | 3197 |
428 | 3198 Lisp_Object |
665 | 3199 make_lcrecord_list (Elemcount size, |
442 | 3200 const struct lrecord_implementation *implementation) |
428 | 3201 { |
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3202 /* Don't use alloc_automanaged_lcrecord() avoid infinite recursion |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
3203 allocating this. */ |
5151
641d0cdd1d00
fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3204 struct lcrecord_list *p = |
641d0cdd1d00
fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3205 XLCRECORD_LIST (old_alloc_lcrecord (&lrecord_lcrecord_list)); |
428 | 3206 |
3207 p->implementation = implementation; | |
3208 p->size = size; | |
3209 p->free = Qnil; | |
793 | 3210 return wrap_lcrecord_list (p); |
428 | 3211 } |
3212 | |
3213 Lisp_Object | |
1204 | 3214 alloc_managed_lcrecord (Lisp_Object lcrecord_list) |
428 | 3215 { |
3216 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
3217 if (!NILP (list->free)) | |
3218 { | |
3219 Lisp_Object val = list->free; | |
3220 struct free_lcrecord_header *free_header = | |
3221 (struct free_lcrecord_header *) XPNTR (val); | |
1204 | 3222 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
428 | 3223 |
3224 #ifdef ERROR_CHECK_GC | |
1204 | 3225 /* Major overkill here. */ |
428 | 3226 /* There should be no other pointers to the free list. */ |
442 | 3227 assert (! MARKED_RECORD_HEADER_P (lheader)); |
428 | 3228 /* Only free lcrecords should be here. */ |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3229 assert (lheader->free); |
1204 | 3230 assert (lheader->type == lrecord_type_free); |
3231 /* Only lcrecords should be here. */ | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3232 assert (! (list->implementation->frob_block_p)); |
1204 | 3233 #if 0 /* Not used anymore, now that we set the type of the header to |
3234 lrecord_type_free. */ | |
428 | 3235 /* The type of the lcrecord must be right. */ |
442 | 3236 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation); |
1204 | 3237 #endif /* 0 */ |
428 | 3238 /* So must the size. */ |
1204 | 3239 assert (list->implementation->static_size == 0 || |
3240 list->implementation->static_size == list->size); | |
428 | 3241 #endif /* ERROR_CHECK_GC */ |
442 | 3242 |
428 | 3243 list->free = free_header->chain; |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3244 lheader->free = 0; |
1204 | 3245 /* Put back the correct type, as we set it to lrecord_type_free. */ |
3246 lheader->type = list->implementation->lrecord_type_index; | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3247 zero_sized_lisp_object (val, list->size); |
428 | 3248 return val; |
3249 } | |
3250 else | |
5151
641d0cdd1d00
fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
3251 return old_alloc_sized_lcrecord (list->size, list->implementation); |
428 | 3252 } |
3253 | |
771 | 3254 /* "Free" a Lisp object LCRECORD by placing it on its associated free list |
1204 | 3255 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the |
771 | 3256 same LCRECORD_LIST as its parameter, it will return an object from the |
3257 free list, which may be this one. Be VERY VERY SURE there are no | |
3258 pointers to this object hanging around anywhere where they might be | |
3259 used! | |
3260 | |
3261 The first thing this does before making any global state change is to | |
3262 call the finalize method of the object, if it exists. */ | |
3263 | |
428 | 3264 void |
3265 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) | |
3266 { | |
3267 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
3268 struct free_lcrecord_header *free_header = | |
3269 (struct free_lcrecord_header *) XPNTR (lcrecord); | |
442 | 3270 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
3271 const struct lrecord_implementation *implementation | |
428 | 3272 = LHEADER_IMPLEMENTATION (lheader); |
3273 | |
4880
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3274 /* If we try to debug-print during GC, we'll likely get a crash on the |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3275 following assert (called from Lstream_delete(), from prin1_to_string()). |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3276 Instead, just don't do anything. Worst comes to worst, we have a |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3277 small memory leak -- and programs being debugged usually won't be |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3278 super long-lived afterwards, anyway. */ |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3279 if (gc_in_progress && in_debug_print) |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3280 return; |
ae81a2c00f4f
try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents:
4803
diff
changeset
|
3281 |
771 | 3282 /* Finalizer methods may try to free objects within them, which typically |
3283 won't be marked and thus are scheduled for demolition. Putting them | |
3284 on the free list would be very bad, as we'd have xfree()d memory in | |
3285 the list. Even if for some reason the objects are still live | |
3286 (generally a logic error!), we still will have problems putting such | |
3287 an object on the free list right now (e.g. we'd have to avoid calling | |
3288 the finalizer twice, etc.). So basically, those finalizers should not | |
3289 be freeing any objects if during GC. Abort now to catch those | |
3290 problems. */ | |
3291 gc_checking_assert (!gc_in_progress); | |
3292 | |
428 | 3293 /* Make sure the size is correct. This will catch, for example, |
3294 putting a window configuration on the wrong free list. */ | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3295 gc_checking_assert (lisp_object_size (lcrecord) == list->size); |
771 | 3296 /* Make sure the object isn't already freed. */ |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3297 gc_checking_assert (!lheader->free); |
2367 | 3298 /* Freeing stuff in dumped memory is bad. If you trip this, you |
3299 may need to check for this before freeing. */ | |
3300 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); | |
771 | 3301 |
428 | 3302 if (implementation->finalizer) |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
3303 implementation->finalizer (lcrecord); |
1204 | 3304 /* Yes, there are two ways to indicate freeness -- the type is |
3305 lrecord_type_free or the ->free flag is set. We used to do only the | |
3306 latter; now we do the former as well for KKCC purposes. Probably | |
3307 safer in any case, as we will lose quicker this way than keeping | |
3308 around an lrecord of apparently correct type but bogus junk in it. */ | |
3309 MARK_LRECORD_AS_FREE (lheader); | |
428 | 3310 free_header->chain = list->free; |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3311 lheader->free = 1; |
428 | 3312 list->free = lcrecord; |
3313 } | |
3314 | |
771 | 3315 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; |
3316 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3317 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3318 alloc_automanaged_sized_lcrecord (Bytecount size, |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3319 const struct lrecord_implementation *imp) |
771 | 3320 { |
3321 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) | |
3322 all_lcrecord_lists[imp->lrecord_type_index] = | |
3323 make_lcrecord_list (size, imp); | |
3324 | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3325 return alloc_managed_lcrecord (all_lcrecord_lists[imp->lrecord_type_index]); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3326 } |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3327 |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3328 Lisp_Object |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3329 alloc_automanaged_lcrecord (const struct lrecord_implementation *imp) |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3330 { |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3331 type_checking_assert (imp->static_size > 0); |
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3063
diff
changeset
|
3332 return alloc_automanaged_sized_lcrecord (imp->static_size, imp); |
771 | 3333 } |
3334 | |
3335 void | |
3024 | 3336 old_free_lcrecord (Lisp_Object rec) |
771 | 3337 { |
3338 int type = XRECORD_LHEADER (rec)->type; | |
3339 | |
3340 assert (!EQ (all_lcrecord_lists[type], Qzero)); | |
3341 | |
3342 free_managed_lcrecord (all_lcrecord_lists[type], rec); | |
3343 } | |
3263 | 3344 #endif /* not NEW_GC */ |
428 | 3345 |
3346 | |
3347 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /* | |
3348 Kept for compatibility, returns its argument. | |
3349 Old: | |
3350 Make a copy of OBJECT in pure storage. | |
3351 Recursively copies contents of vectors and cons cells. | |
3352 Does not copy symbols. | |
3353 */ | |
444 | 3354 (object)) |
428 | 3355 { |
444 | 3356 return object; |
428 | 3357 } |
3358 | |
3359 | |
3360 /************************************************************************/ | |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3361 /* Staticpro, MCpro */ |
428 | 3362 /************************************************************************/ |
3363 | |
771 | 3364 /* We want the staticpro list relocated, but not the pointers found |
3365 therein, because they refer to locations in the global data segment, not | |
3366 in the heap; we only dump heap objects. Hence we use a trivial | |
3367 description, as for pointerless objects. (Note that the data segment | |
3368 objects, which are global variables like Qfoo or Vbar, themselves are | |
3369 pointers to heap objects. Each needs to be described to pdump as a | |
3370 "root pointer"; this happens in the call to staticpro(). */ | |
1204 | 3371 static const struct memory_description staticpro_description_1[] = { |
452 | 3372 { XD_END } |
3373 }; | |
3374 | |
1204 | 3375 static const struct sized_memory_description staticpro_description = { |
452 | 3376 sizeof (Lisp_Object *), |
3377 staticpro_description_1 | |
3378 }; | |
3379 | |
1204 | 3380 static const struct memory_description staticpros_description_1[] = { |
452 | 3381 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description), |
3382 { XD_END } | |
3383 }; | |
3384 | |
1204 | 3385 static const struct sized_memory_description staticpros_description = { |
452 | 3386 sizeof (Lisp_Object_ptr_dynarr), |
3387 staticpros_description_1 | |
3388 }; | |
3389 | |
771 | 3390 #ifdef DEBUG_XEMACS |
3391 | |
3392 /* Help debug crashes gc-marking a staticpro'ed object. */ | |
3393 | |
3394 Lisp_Object_ptr_dynarr *staticpros; | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3395 const_Ascbyte_ptr_dynarr *staticpro_names; |
771 | 3396 |
3397 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
3398 garbage collection, and for dumping. */ | |
3399 void | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3400 staticpro_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
771 | 3401 { |
3402 Dynarr_add (staticpros, varaddress); | |
3403 Dynarr_add (staticpro_names, varname); | |
1204 | 3404 dump_add_root_lisp_object (varaddress); |
771 | 3405 } |
3406 | |
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3407 const Ascbyte *staticpro_name (int count); |
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3408 |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3409 /* External debugging function: Return the name of the variable at offset |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3410 COUNT. */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3411 const Ascbyte * |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3412 staticpro_name (int count) |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3413 { |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3414 return Dynarr_at (staticpro_names, count); |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3415 } |
771 | 3416 |
3417 Lisp_Object_ptr_dynarr *staticpros_nodump; | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3418 const_Ascbyte_ptr_dynarr *staticpro_nodump_names; |
771 | 3419 |
3420 /* Mark the Lisp_Object at heap VARADDRESS as a root object for | |
3421 garbage collection, but not for dumping. (See below.) */ | |
3422 void | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3423 staticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
771 | 3424 { |
3425 Dynarr_add (staticpros_nodump, varaddress); | |
3426 Dynarr_add (staticpro_nodump_names, varname); | |
3427 } | |
3428 | |
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3429 const Ascbyte *staticpro_nodump_name (int count); |
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3430 |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3431 /* External debugging function: Return the name of the variable at offset |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3432 COUNT. */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3433 const Ascbyte * |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3434 staticpro_nodump_name (int count) |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3435 { |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3436 return Dynarr_at (staticpro_nodump_names, count); |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3437 } |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3438 |
996 | 3439 #ifdef HAVE_SHLIB |
3440 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object | |
3441 for garbage collection, but not for dumping. */ | |
3442 void | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3443 unstaticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname) |
996 | 3444 { |
3445 Dynarr_delete_object (staticpros, varaddress); | |
3446 Dynarr_delete_object (staticpro_names, varname); | |
3447 } | |
3448 #endif | |
3449 | |
771 | 3450 #else /* not DEBUG_XEMACS */ |
3451 | |
452 | 3452 Lisp_Object_ptr_dynarr *staticpros; |
3453 | |
3454 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
3455 garbage collection, and for dumping. */ | |
428 | 3456 void |
3457 staticpro (Lisp_Object *varaddress) | |
3458 { | |
452 | 3459 Dynarr_add (staticpros, varaddress); |
1204 | 3460 dump_add_root_lisp_object (varaddress); |
428 | 3461 } |
3462 | |
442 | 3463 |
452 | 3464 Lisp_Object_ptr_dynarr *staticpros_nodump; |
3465 | |
771 | 3466 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage |
3467 collection, but not for dumping. This is used for objects where the | |
3468 only sure pointer is in the heap (rather than in the global data | |
3469 segment, as must be the case for pdump root pointers), but not inside of | |
3470 another Lisp object (where it will be marked as a result of that Lisp | |
3471 object's mark method). The call to staticpro_nodump() must occur *BOTH* | |
3472 at initialization time and at "reinitialization" time (startup, after | |
3473 pdump load.) (For example, this is the case with the predicate symbols | |
3474 for specifier and coding system types. The pointer to this symbol is | |
3475 inside of a methods structure, which is allocated on the heap. The | |
3476 methods structure will be written out to the pdump data file, and may be | |
3477 reloaded at a different address.) | |
3478 | |
3479 #### The necessity for reinitialization is a bug in pdump. Pdump should | |
3480 automatically regenerate the staticpro()s for these symbols when it | |
3481 loads the data in. */ | |
3482 | |
428 | 3483 void |
3484 staticpro_nodump (Lisp_Object *varaddress) | |
3485 { | |
452 | 3486 Dynarr_add (staticpros_nodump, varaddress); |
428 | 3487 } |
3488 | |
996 | 3489 #ifdef HAVE_SHLIB |
3490 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for | |
3491 garbage collection, but not for dumping. */ | |
3492 void | |
3493 unstaticpro_nodump (Lisp_Object *varaddress) | |
3494 { | |
3495 Dynarr_delete_object (staticpros, varaddress); | |
3496 } | |
3497 #endif | |
3498 | |
771 | 3499 #endif /* not DEBUG_XEMACS */ |
3500 | |
3263 | 3501 #ifdef NEW_GC |
2720 | 3502 static const struct memory_description mcpro_description_1[] = { |
3503 { XD_END } | |
3504 }; | |
3505 | |
3506 static const struct sized_memory_description mcpro_description = { | |
3507 sizeof (Lisp_Object *), | |
3508 mcpro_description_1 | |
3509 }; | |
3510 | |
3511 static const struct memory_description mcpros_description_1[] = { | |
3512 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description), | |
3513 { XD_END } | |
3514 }; | |
3515 | |
3516 static const struct sized_memory_description mcpros_description = { | |
3517 sizeof (Lisp_Object_dynarr), | |
3518 mcpros_description_1 | |
3519 }; | |
3520 | |
3521 #ifdef DEBUG_XEMACS | |
3522 | |
3523 /* Help debug crashes gc-marking a mcpro'ed object. */ | |
3524 | |
3525 Lisp_Object_dynarr *mcpros; | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3526 const_Ascbyte_ptr_dynarr *mcpro_names; |
2720 | 3527 |
3528 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
3529 garbage collection, and for dumping. */ | |
3530 void | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3531 mcpro_1 (Lisp_Object varaddress, const Ascbyte *varname) |
2720 | 3532 { |
3533 Dynarr_add (mcpros, varaddress); | |
3534 Dynarr_add (mcpro_names, varname); | |
3535 } | |
3536 | |
5046 | 3537 const Ascbyte *mcpro_name (int count); |
3538 | |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3539 /* External debugging function: Return the name of the variable at offset |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3540 COUNT. */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
3541 const Ascbyte * |
4934
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3542 mcpro_name (int count) |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3543 { |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3544 return Dynarr_at (mcpro_names, count); |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3545 } |
714f7c9fabb1
make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents:
4880
diff
changeset
|
3546 |
2720 | 3547 #else /* not DEBUG_XEMACS */ |
3548 | |
3549 Lisp_Object_dynarr *mcpros; | |
3550 | |
3551 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
3552 garbage collection, and for dumping. */ | |
3553 void | |
3554 mcpro (Lisp_Object varaddress) | |
3555 { | |
3556 Dynarr_add (mcpros, varaddress); | |
3557 } | |
3558 | |
3559 #endif /* not DEBUG_XEMACS */ | |
3263 | 3560 #endif /* NEW_GC */ |
3561 | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3562 #ifdef ALLOC_TYPE_STATS |
428 | 3563 |
3564 | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3565 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3566 /* Determining allocation overhead */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3567 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3568 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3569 /* Attempt to determine the actual amount of space that is used for |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3570 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3571 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3572 It seems that the following holds: |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3573 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3574 1. When using the old allocator (malloc.c): |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3575 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3576 -- blocks are always allocated in chunks of powers of two. For |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3577 each block, there is an overhead of 8 bytes if rcheck is not |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3578 defined, 20 bytes if it is defined. In other words, a |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3579 one-byte allocation needs 8 bytes of overhead for a total of |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3580 9 bytes, and needs to have 16 bytes of memory chunked out for |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3581 it. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3582 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3583 2. When using the new allocator (gmalloc.c): |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3584 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3585 -- blocks are always allocated in chunks of powers of two up |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3586 to 4096 bytes. Larger blocks are allocated in chunks of |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3587 an integral multiple of 4096 bytes. The minimum block |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3588 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3589 is defined. There is no per-block overhead, but there |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3590 is an overhead of 3*sizeof (size_t) for each 4096 bytes |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3591 allocated. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3592 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3593 3. When using the system malloc, anything goes, but they are |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3594 generally slower and more space-efficient than the GNU |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3595 allocators. One possibly reasonable assumption to make |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3596 for want of better data is that sizeof (void *), or maybe |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3597 2 * sizeof (void *), is required as overhead and that |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3598 blocks are allocated in the minimum required size except |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3599 that some minimum block size is imposed (e.g. 16 bytes). */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3600 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3601 Bytecount |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3602 malloced_storage_size (void * UNUSED (ptr), Bytecount claimed_size, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3603 struct usage_stats *stats) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3604 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3605 Bytecount orig_claimed_size = claimed_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3606 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3607 #ifndef SYSTEM_MALLOC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3608 if (claimed_size < (Bytecount) (2 * sizeof (void *))) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3609 claimed_size = 2 * sizeof (void *); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3610 # ifdef SUNOS_LOCALTIME_BUG |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3611 if (claimed_size < 16) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3612 claimed_size = 16; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3613 # endif |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3614 if (claimed_size < 4096) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3615 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3616 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3617 int log2 = 1; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3618 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3619 /* compute the log base two, more or less, then use it to compute |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3620 the block size needed. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3621 claimed_size--; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3622 /* It's big, it's heavy, it's wood! */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3623 while ((claimed_size /= 2) != 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3624 ++log2; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3625 claimed_size = 1; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3626 /* It's better than bad, it's good! */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3627 while (log2 > 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3628 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3629 claimed_size *= 2; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3630 log2--; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3631 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3632 /* We have to come up with some average about the amount of |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3633 blocks used. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3634 if ((Bytecount) (rand () & 4095) < claimed_size) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3635 claimed_size += 3 * sizeof (void *); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3636 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3637 else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3638 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3639 claimed_size += 4095; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3640 claimed_size &= ~4095; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3641 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3642 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3643 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3644 #else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3645 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3646 if (claimed_size < 16) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3647 claimed_size = 16; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3648 claimed_size += 2 * sizeof (void *); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3649 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3650 #endif /* system allocator */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3651 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3652 if (stats) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3653 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3654 stats->was_requested += orig_claimed_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3655 stats->malloc_overhead += claimed_size - orig_claimed_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3656 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3657 return claimed_size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3658 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3659 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3660 #ifndef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3661 static Bytecount |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3662 fixed_type_block_overhead (Bytecount size, Bytecount per_block) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3663 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3664 Bytecount overhead = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3665 Bytecount storage_size = malloced_storage_size (0, per_block, 0); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3666 while (size >= per_block) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3667 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3668 size -= per_block; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3669 overhead += storage_size - per_block; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3670 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3671 if (rand () % per_block < size) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3672 overhead += storage_size - per_block; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3673 return overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3674 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3675 #endif /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3676 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3677 Bytecount |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3678 lisp_object_storage_size (Lisp_Object obj, struct usage_stats *ustats) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3679 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3680 #ifndef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3681 const struct lrecord_implementation *imp = |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3682 XRECORD_LHEADER_IMPLEMENTATION (obj); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3683 #endif /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3684 Bytecount size = lisp_object_size (obj); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3685 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3686 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3687 return mc_alloced_storage_size (size, ustats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3688 #else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3689 if (imp->frob_block_p) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3690 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3691 Bytecount overhead = |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3692 /* #### Always using cons_block is incorrect but close; only |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3693 string_chars_block is significantly different in size, and |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3694 it won't ever be seen in this function */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3695 fixed_type_block_overhead (size, sizeof (struct cons_block)); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3696 if (ustats) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3697 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3698 ustats->was_requested += size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3699 ustats->malloc_overhead += overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3700 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3701 return size + overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3702 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3703 else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3704 return malloced_storage_size (XPNTR (obj), size, ustats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3705 #endif |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3706 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3707 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3708 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3709 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3710 /* Allocation Statistics: Accumulate */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3711 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3712 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3713 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3714 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3715 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3716 init_lrecord_stats (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3717 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3718 xzero (lrecord_stats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3719 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3720 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3721 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3722 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3723 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3724 int type_index = h->type; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3725 if (!size) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3726 size = detagged_lisp_object_size (h); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3727 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3728 lrecord_stats[type_index].instances_in_use++; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3729 lrecord_stats[type_index].bytes_in_use += size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3730 lrecord_stats[type_index].bytes_in_use_including_overhead |
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3731 #ifdef MEMORY_USAGE_STATS |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3732 += mc_alloced_storage_size (size, 0); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3733 #else /* not MEMORY_USAGE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3734 += size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3735 #endif /* not MEMORY_USAGE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3736 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3737 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3738 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3739 dec_lrecord_stats (Bytecount size_including_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3740 const struct lrecord_header *h) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3741 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3742 int type_index = h->type; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3743 int size = detagged_lisp_object_size (h); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3744 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3745 lrecord_stats[type_index].instances_in_use--; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3746 lrecord_stats[type_index].bytes_in_use -= size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3747 lrecord_stats[type_index].bytes_in_use_including_overhead |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3748 -= size_including_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3749 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3750 DECREMENT_CONS_COUNTER (size); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3751 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3752 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3753 int |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3754 lrecord_stats_heap_size (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3755 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3756 int i; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3757 int size = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3758 for (i = 0; i < countof (lrecord_implementations_table); i++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3759 size += lrecord_stats[i].bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3760 return size; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3761 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3762 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3763 #else /* not NEW_GC */ |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3764 |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3765 static void |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3766 clear_lrecord_stats (void) |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3767 { |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3768 xzero (lrecord_stats); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3769 gc_count_num_short_string_in_use = 0; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3770 gc_count_string_total_size = 0; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3771 gc_count_short_string_total_size = 0; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3772 gc_count_long_string_storage_including_overhead = 0; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3773 } |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3774 |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3775 /* Keep track of extra statistics for strings -- length of the string |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3776 characters for short and long strings, number of short and long strings. */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3777 static void |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3778 tick_string_stats (Lisp_String *p, int from_sweep) |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3779 { |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3780 Bytecount size = p->size_; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3781 gc_count_string_total_size += size; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3782 if (!BIG_STRING_SIZE_P (size)) |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3783 { |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3784 gc_count_short_string_total_size += size; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3785 gc_count_num_short_string_in_use++; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3786 } |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3787 else |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3788 gc_count_long_string_storage_including_overhead += |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3789 malloced_storage_size (p->data_, p->size_, NULL); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3790 /* During the sweep stage, we count the total number of strings in use. |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3791 This gets those not stored in pdump storage. For pdump storage, we |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3792 need to bump the number of strings in use so as to get an accurate |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3793 count of all strings in use (pdump or not). But don't do this when |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3794 called from the sweep stage, or we will double-count. */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3795 if (!from_sweep) |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3796 gc_count_num_string_in_use++; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3797 } |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3798 |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3799 /* As objects are sweeped, we record statistics about their memory usage. |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3800 Currently, all lcrecords are processed this way as well as any frob-block |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3801 objects that were saved and restored as a result of the pdump process. |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3802 (See pdump_objects_unmark().) Other frob-block objects do NOT get their |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3803 statistics noted this way -- instead, as the frob blocks are swept, |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3804 COPY_INTO_LRECORD_STATS() is called, and notes statistics about the |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3805 frob blocks. */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3806 |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3807 void |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3808 tick_lrecord_stats (const struct lrecord_header *h, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3809 enum lrecord_alloc_status status) |
428 | 3810 { |
647 | 3811 int type_index = h->type; |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3812 Bytecount obj = wrap_pointer_1 (h); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3813 Bytecount sz = lisp_object_size (obj); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3814 Bytecount sz_with_overhead = lisp_object_storage_size (obj, NULL); |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3815 Bytecount overhead = sz_with_overhead - sz; |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3816 |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3817 switch (status) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3818 { |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3819 case ALLOC_IN_USE: |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3820 lrecord_stats[type_index].instances_in_use++; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3821 lrecord_stats[type_index].bytes_in_use += sz; |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3822 lrecord_stats[type_index].bytes_in_use_overhead += overhead; |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3823 if (STRINGP (obj)) |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3824 tick_string_stats (XSTRING (obj), 0); |
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3825 #ifdef MEMORY_USAGE_STATS |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3826 { |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3827 struct generic_usage_stats stats; |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3828 if (HAS_OBJECT_METH_P (obj, memory_usage)) |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3829 { |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3830 int i; |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3831 int total_stats = OBJECT_PROPERTY (obj, num_extra_memusage_stats); |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3832 xzero (stats); |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3833 OBJECT_METH (obj, memory_usage, (obj, &stats)); |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3834 for (i = 0; i < total_stats; i++) |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3835 lrecord_stats[type_index].stats.othervals[i] += |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3836 stats.othervals[i]; |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3837 } |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3838 } |
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
3839 #endif |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3840 break; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3841 case ALLOC_FREE: |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3842 lrecord_stats[type_index].instances_freed++; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3843 lrecord_stats[type_index].bytes_freed += sz; |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3844 lrecord_stats[type_index].bytes_freed_overhead += overhead; |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3845 break; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3846 case ALLOC_ON_FREE_LIST: |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3847 lrecord_stats[type_index].instances_on_free_list++; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3848 lrecord_stats[type_index].bytes_on_free_list += sz; |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3849 lrecord_stats[type_index].bytes_on_free_list_overhead += overhead; |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3850 break; |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3851 default: |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3852 ABORT (); |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3853 } |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3854 } |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3855 |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3856 inline static void |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3857 tick_lcrecord_stats (const struct lrecord_header *h, int free_p) |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3858 { |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
3859 if (h->free) |
428 | 3860 { |
442 | 3861 gc_checking_assert (!free_p); |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3862 tick_lrecord_stats (h, ALLOC_ON_FREE_LIST); |
428 | 3863 } |
3864 else | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
3865 tick_lrecord_stats (h, free_p ? ALLOC_FREE : ALLOC_IN_USE); |
428 | 3866 } |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
3867 |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3868 #endif /* (not) NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3869 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3870 void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3871 finish_object_memory_usage_stats (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3872 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3873 /* Here we add up the aggregate values for each statistic, previously |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3874 computed during tick_lrecord_stats(), to get a single combined value |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3875 of non-Lisp memory usage for all objects of each type. We can't |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3876 do this if NEW_GC because nothing like tick_lrecord_stats() gets |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3877 called -- instead, statistics are computed when objects are allocated, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3878 which is too early to be calling the memory_usage() method. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3879 #if defined (MEMORY_USAGE_STATS) && !defined (NEW_GC) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3880 int i; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3881 for (i = 0; i < countof (lrecord_implementations_table); i++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3882 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3883 struct lrecord_implementation *imp = lrecord_implementations_table[i]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3884 if (imp && imp->num_extra_nonlisp_memusage_stats) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3885 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3886 int j; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3887 for (j = 0; j < imp->num_extra_nonlisp_memusage_stats; j++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3888 lrecord_stats[i].nonlisp_bytes_in_use += |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3889 lrecord_stats[i].stats.othervals[j]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3890 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3891 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3892 #endif /* defined (MEMORY_USAGE_STATS) && !defined (NEW_GC) */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3893 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3894 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3895 #define COUNT_FROB_BLOCK_USAGE(type) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3896 EMACS_INT s = 0; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3897 EMACS_INT s_overhead = 0; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3898 struct type##_block *x = current_##type##_block; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3899 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3900 s_overhead = fixed_type_block_overhead (s, sizeof (struct type##_block)); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3901 DO_NOTHING |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3902 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3903 #define COPY_INTO_LRECORD_STATS(type) \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3904 do { \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3905 COUNT_FROB_BLOCK_USAGE (type); \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3906 lrecord_stats[lrecord_type_##type].bytes_in_use += s; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3907 lrecord_stats[lrecord_type_##type].bytes_in_use_overhead += \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3908 s_overhead; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3909 lrecord_stats[lrecord_type_##type].instances_on_free_list += \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3910 gc_count_num_##type##_freelist; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3911 lrecord_stats[lrecord_type_##type].instances_in_use += \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3912 gc_count_num_##type##_in_use; \ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3913 } while (0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3914 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3915 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3916 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3917 /* Allocation statistics: format nicely */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3918 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3919 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3920 static Lisp_Object |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3921 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3922 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3923 /* C doesn't have local functions (or closures, or GC, or readable syntax, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3924 or portable numeric datatypes, or bit-vectors, or characters, or |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3925 arrays, or exceptions, or ...) */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3926 return cons3 (intern (name), make_int (value), tail); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3927 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3928 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3929 /* Pluralize a lowercase English word stored in BUF, assuming BUF has |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3930 enough space to hold the extra letters (at most 2). */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3931 static void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3932 pluralize_word (Ascbyte *buf) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3933 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3934 Bytecount len = strlen (buf); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3935 int upper = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3936 Ascbyte d, e; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3937 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3938 if (len == 0 || len == 1) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3939 goto pluralize_apostrophe_s; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3940 e = buf[len - 1]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3941 d = buf[len - 2]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3942 upper = isupper (e); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3943 e = tolower (e); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3944 d = tolower (d); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3945 if (e == 'y') |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3946 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3947 switch (d) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3948 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3949 case 'a': |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3950 case 'e': |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3951 case 'i': |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3952 case 'o': |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3953 case 'u': |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3954 goto pluralize_s; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3955 default: |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3956 buf[len - 1] = (upper ? 'I' : 'i'); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3957 goto pluralize_es; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3958 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3959 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3960 else if (e == 's' || e == 'x' || (e == 'h' && (d == 's' || d == 'c'))) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3961 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3962 pluralize_es: |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3963 buf[len++] = (upper ? 'E' : 'e'); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3964 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3965 pluralize_s: |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3966 buf[len++] = (upper ? 'S' : 's'); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3967 buf[len] = '\0'; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3968 return; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3969 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3970 pluralize_apostrophe_s: |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3971 buf[len++] = '\''; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3972 goto pluralize_s; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3973 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3974 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3975 static void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3976 pluralize_and_append (Ascbyte *buf, const Ascbyte *name, const Ascbyte *suffix) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3977 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3978 strcpy (buf, name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3979 pluralize_word (buf); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3980 strcat (buf, suffix); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3981 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3982 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3983 static Lisp_Object |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3984 object_memory_usage_stats (int set_total_gc_usage) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3985 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3986 Lisp_Object pl = Qnil; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3987 int i; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3988 EMACS_INT tgu_val = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3989 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3990 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3991 for (i = 0; i < countof (lrecord_implementations_table); i++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3992 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3993 if (lrecord_stats[i].instances_in_use != 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3994 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3995 Ascbyte buf[255]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3996 const Ascbyte *name = lrecord_implementations_table[i]->name; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3997 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3998 if (lrecord_stats[i].bytes_in_use_including_overhead != |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
3999 lrecord_stats[i].bytes_in_use) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4000 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4001 sprintf (buf, "%s-storage-including-overhead", name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4002 pl = gc_plist_hack (buf, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4003 lrecord_stats[i] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4004 .bytes_in_use_including_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4005 pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4006 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4007 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4008 sprintf (buf, "%s-storage", name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4009 pl = gc_plist_hack (buf, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4010 lrecord_stats[i].bytes_in_use, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4011 pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4012 tgu_val += lrecord_stats[i].bytes_in_use_including_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4013 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4014 pluralize_and_append (buf, name, "-used"); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4015 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4016 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4017 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4018 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4019 #else /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4020 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4021 for (i = 0; i < lrecord_type_count; i++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4022 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4023 if (lrecord_stats[i].bytes_in_use != 0 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4024 || lrecord_stats[i].bytes_freed != 0 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4025 || lrecord_stats[i].instances_on_free_list != 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4026 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4027 Ascbyte buf[255]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4028 const Ascbyte *name = lrecord_implementations_table[i]->name; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4029 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4030 sprintf (buf, "%s-storage-overhead", name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4031 pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use_overhead, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4032 tgu_val += lrecord_stats[i].bytes_in_use_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4033 sprintf (buf, "%s-storage", name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4034 pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4035 tgu_val += lrecord_stats[i].bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4036 #ifdef MEMORY_USAGE_STATS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4037 if (lrecord_stats[i].nonlisp_bytes_in_use) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4038 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4039 sprintf (buf, "%s-non-lisp-storage", name); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4040 pl = gc_plist_hack (buf, lrecord_stats[i].nonlisp_bytes_in_use, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4041 pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4042 tgu_val += lrecord_stats[i].nonlisp_bytes_in_use; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4043 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4044 #endif /* MEMORY_USAGE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4045 pluralize_and_append (buf, name, "-freed"); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4046 if (lrecord_stats[i].instances_freed != 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4047 pl = gc_plist_hack (buf, lrecord_stats[i].instances_freed, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4048 pluralize_and_append (buf, name, "-on-free-list"); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4049 if (lrecord_stats[i].instances_on_free_list != 0) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4050 pl = gc_plist_hack (buf, lrecord_stats[i].instances_on_free_list, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4051 pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4052 pluralize_and_append (buf, name, "-used"); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4053 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4054 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4055 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4056 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4057 pl = gc_plist_hack ("long-string-chars-storage-overhead", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4058 gc_count_long_string_storage_including_overhead - |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4059 (gc_count_string_total_size |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4060 - gc_count_short_string_total_size), pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4061 pl = gc_plist_hack ("long-string-chars-storage", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4062 gc_count_string_total_size |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4063 - gc_count_short_string_total_size, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4064 do |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4065 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4066 COUNT_FROB_BLOCK_USAGE (string_chars); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4067 tgu_val += s + s_overhead; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4068 pl = gc_plist_hack ("short-string-chars-storage-overhead", s_overhead, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4069 pl = gc_plist_hack ("short-string-chars-storage", s, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4070 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4071 while (0); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4072 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4073 pl = gc_plist_hack ("long-strings-total-length", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4074 gc_count_string_total_size |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4075 - gc_count_short_string_total_size, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4076 pl = gc_plist_hack ("short-strings-total-length", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4077 gc_count_short_string_total_size, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4078 pl = gc_plist_hack ("long-strings-used", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4079 gc_count_num_string_in_use |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4080 - gc_count_num_short_string_in_use, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4081 pl = gc_plist_hack ("short-strings-used", |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4082 gc_count_num_short_string_in_use, pl); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4083 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4084 #endif /* NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4085 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4086 if (set_total_gc_usage) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4087 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4088 total_gc_usage = tgu_val; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4089 total_gc_usage_set = 1; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4090 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4091 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4092 return pl; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4093 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4094 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4095 static Lisp_Object |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4096 garbage_collection_statistics (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4097 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4098 /* The things we do for backwards-compatibility */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4099 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4100 return |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4101 list6 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4102 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4103 make_int (lrecord_stats[lrecord_type_cons] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4104 .bytes_in_use_including_overhead)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4105 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4106 make_int (lrecord_stats[lrecord_type_symbol] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4107 .bytes_in_use_including_overhead)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4108 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4109 make_int (lrecord_stats[lrecord_type_marker] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4110 .bytes_in_use_including_overhead)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4111 make_int (lrecord_stats[lrecord_type_string] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4112 .bytes_in_use_including_overhead), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4113 make_int (lrecord_stats[lrecord_type_vector] |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4114 .bytes_in_use_including_overhead), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4115 object_memory_usage_stats (1)); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4116 #else /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4117 return |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4118 list6 (Fcons (make_int (gc_count_num_cons_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4119 make_int (gc_count_num_cons_freelist)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4120 Fcons (make_int (gc_count_num_symbol_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4121 make_int (gc_count_num_symbol_freelist)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4122 Fcons (make_int (gc_count_num_marker_in_use), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4123 make_int (gc_count_num_marker_freelist)), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4124 make_int (gc_count_string_total_size), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4125 make_int (lrecord_stats[lrecord_type_vector].bytes_in_use + |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4126 lrecord_stats[lrecord_type_vector].bytes_freed + |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4127 lrecord_stats[lrecord_type_vector].bytes_on_free_list), |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4128 object_memory_usage_stats (1)); |
3263 | 4129 #endif /* not NEW_GC */ |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4130 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4131 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4132 DEFUN ("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0, 0, /* |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4133 Return statistics about memory usage of Lisp objects. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4134 */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4135 ()) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4136 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4137 return object_memory_usage_stats (0); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4138 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4139 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4140 #endif /* ALLOC_TYPE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4141 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4142 #ifdef MEMORY_USAGE_STATS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4143 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4144 DEFUN ("object-memory-usage", Fobject_memory_usage, 1, 1, 0, /* |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4145 Return stats about the memory usage of OBJECT. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4146 The values returned are in the form of an alist of usage types and byte |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4147 counts. The byte counts attempt to encompass all the memory used |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4148 by the object (separate from the memory logically associated with any |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4149 other object), including internal structures and any malloc() |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4150 overhead associated with them. In practice, the byte counts are |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4151 underestimated because certain memory usage is very hard to determine |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4152 \(e.g. the amount of memory used inside the Xt library or inside the |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4153 X server). |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4154 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4155 Multiple slices of the total memory usage may be returned, separated |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4156 by a nil. Each slice represents a particular view of the memory, a |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4157 particular way of partitioning it into groups. Within a slice, there |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4158 is no overlap between the groups of memory, and each slice collectively |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4159 represents all the memory concerned. The rightmost slice typically |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4160 represents the total memory used plus malloc and dynarr overhead. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4161 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4162 Slices describing other Lisp objects logically associated with the |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4163 object may be included, separated from other slices by `t' and from |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4164 each other by nil if there is more than one. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4165 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4166 #### We have to figure out how to handle the memory used by the object |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4167 itself vs. the memory used by substructures. Probably the memory_usage |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4168 method should return info only about substructures and related Lisp |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4169 objects, since the caller can always find and all info about the object |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4170 itself. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4171 */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4172 (object)) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4173 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4174 struct generic_usage_stats gustats; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4175 struct usage_stats object_stats; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4176 int i; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4177 Lisp_Object val = Qnil; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4178 Lisp_Object stats_list = OBJECT_PROPERTY (object, memusage_stats_list); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4179 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4180 xzero (object_stats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4181 lisp_object_storage_size (object, &object_stats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4182 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4183 val = acons (Qobject_actually_requested, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4184 make_int (object_stats.was_requested), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4185 val = acons (Qobject_malloc_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4186 make_int (object_stats.malloc_overhead), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4187 assert (!object_stats.dynarr_overhead); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4188 assert (!object_stats.gap_overhead); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4189 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4190 if (!NILP (stats_list)) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4191 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4192 xzero (gustats); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4193 MAYBE_OBJECT_METH (object, memory_usage, (object, &gustats)); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4194 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4195 val = Fcons (Qt, val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4196 val = acons (Qother_memory_actually_requested, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4197 make_int (gustats.u.was_requested), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4198 val = acons (Qother_memory_malloc_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4199 make_int (gustats.u.malloc_overhead), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4200 if (gustats.u.dynarr_overhead) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4201 val = acons (Qother_memory_dynarr_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4202 make_int (gustats.u.dynarr_overhead), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4203 if (gustats.u.gap_overhead) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4204 val = acons (Qother_memory_gap_overhead, |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4205 make_int (gustats.u.gap_overhead), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4206 val = Fcons (Qnil, val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4207 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4208 i = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4209 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4210 LIST_LOOP_2 (item, stats_list) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4211 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4212 if (NILP (item) || EQ (item, Qt)) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4213 val = Fcons (item, val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4214 else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4215 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4216 val = acons (item, make_int (gustats.othervals[i]), val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4217 i++; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4218 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4219 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4220 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4221 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4222 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4223 return Fnreverse (val); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4224 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4225 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4226 #endif /* MEMORY_USAGE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4227 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4228 #ifdef ALLOC_TYPE_STATS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4229 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4230 DEFUN ("total-object-memory-usage", Ftotal_object_memory_usage, 0, 0, 0, /* |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4231 Return total number of bytes used for object storage in XEmacs. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4232 This may be helpful in debugging XEmacs's memory usage. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4233 See also `consing-since-gc' and `object-memory-usage-stats'. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4234 */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4235 ()) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4236 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4237 return make_int (total_gc_usage + consing_since_gc); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4238 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4239 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4240 #endif /* ALLOC_TYPE_STATS */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4241 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4242 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4243 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4244 /* Allocation statistics: Initialization */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4245 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4246 #ifdef MEMORY_USAGE_STATS |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4247 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4248 /* Compute the number of extra memory-usage statistics associated with an |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4249 object. We can't compute this at the time INIT_LISP_OBJECT() is called |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4250 because the value of the `memusage_stats_list' property is generally |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4251 set afterwards. So we compute the values for all types of objects |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4252 after all objects have been initialized. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4253 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4254 static void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4255 compute_memusage_stats_length (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4256 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4257 int i; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4258 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4259 for (i = 0; i < countof (lrecord_implementations_table); i++) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4260 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4261 int len = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4262 int nonlisp_len = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4263 int seen_break = 0; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4264 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4265 struct lrecord_implementation *imp = lrecord_implementations_table[i]; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4266 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4267 if (!imp) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4268 continue; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4269 /* For some of the early objects, Qnil was not yet initialized at |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4270 the time of object initialization, so it came up as Qnull_pointer. |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4271 Fix that now. */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4272 if (EQ (imp->memusage_stats_list, Qnull_pointer)) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4273 imp->memusage_stats_list = Qnil; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4274 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4275 LIST_LOOP_2 (item, imp->memusage_stats_list) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4276 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4277 if (!NILP (item) && !EQ (item, Qt)) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4278 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4279 len++; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4280 if (!seen_break) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4281 nonlisp_len++; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4282 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4283 else |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4284 seen_break++; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4285 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4286 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4287 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4288 imp->num_extra_memusage_stats = len; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4289 imp->num_extra_nonlisp_memusage_stats = nonlisp_len; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4290 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4291 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4292 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
4293 #endif /* MEMORY_USAGE_STATS */ |
428 | 4294 |
4295 | |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
4296 /************************************************************************/ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
4297 /* Garbage Collection -- Sweep/Compact */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
4298 /************************************************************************/ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
4299 |
3263 | 4300 #ifndef NEW_GC |
428 | 4301 /* Free all unmarked records */ |
4302 static void | |
3024 | 4303 sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used) |
4304 { | |
4305 struct old_lcrecord_header *header; | |
428 | 4306 int num_used = 0; |
4307 /* int total_size = 0; */ | |
4308 | |
4309 /* First go through and call all the finalize methods. | |
4310 Then go through and free the objects. There used to | |
4311 be only one loop here, with the call to the finalizer | |
4312 occurring directly before the xfree() below. That | |
4313 is marginally faster but much less safe -- if the | |
4314 finalize method for an object needs to reference any | |
4315 other objects contained within it (and many do), | |
4316 we could easily be screwed by having already freed that | |
4317 other object. */ | |
4318 | |
4319 for (header = *prev; header; header = header->next) | |
4320 { | |
4321 struct lrecord_header *h = &(header->lheader); | |
442 | 4322 |
4323 GC_CHECK_LHEADER_INVARIANTS (h); | |
4324 | |
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
4325 if (! MARKED_RECORD_HEADER_P (h) && !h->free) |
428 | 4326 { |
4327 if (LHEADER_IMPLEMENTATION (h)->finalizer) | |
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
4328 LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h)); |
428 | 4329 } |
4330 } | |
4331 | |
4332 for (header = *prev; header; ) | |
4333 { | |
4334 struct lrecord_header *h = &(header->lheader); | |
442 | 4335 if (MARKED_RECORD_HEADER_P (h)) |
428 | 4336 { |
442 | 4337 if (! C_READONLY_RECORD_HEADER_P (h)) |
428 | 4338 UNMARK_RECORD_HEADER (h); |
4339 num_used++; | |
4340 /* total_size += n->implementation->size_in_bytes (h);*/ | |
440 | 4341 /* #### May modify header->next on a C_READONLY lcrecord */ |
428 | 4342 prev = &(header->next); |
4343 header = *prev; | |
4344 tick_lcrecord_stats (h, 0); | |
4345 } | |
4346 else | |
4347 { | |
3024 | 4348 struct old_lcrecord_header *next = header->next; |
428 | 4349 *prev = next; |
4350 tick_lcrecord_stats (h, 1); | |
4351 /* used to call finalizer right here. */ | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4352 xfree (header); |
428 | 4353 header = next; |
4354 } | |
4355 } | |
4356 *used = num_used; | |
4357 /* *total = total_size; */ | |
4358 } | |
4359 | |
4360 /* And the Lord said: Thou shalt use the `c-backslash-region' command | |
4361 to make macros prettier. */ | |
4362 | |
4363 #ifdef ERROR_CHECK_GC | |
4364 | |
771 | 4365 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
428 | 4366 do { \ |
4367 struct typename##_block *SFTB_current; \ | |
4368 int SFTB_limit; \ | |
4369 int num_free = 0, num_used = 0; \ | |
4370 \ | |
444 | 4371 for (SFTB_current = current_##typename##_block, \ |
428 | 4372 SFTB_limit = current_##typename##_block_index; \ |
4373 SFTB_current; \ | |
4374 ) \ | |
4375 { \ | |
4376 int SFTB_iii; \ | |
4377 \ | |
4378 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
4379 { \ | |
4380 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
4381 \ | |
454 | 4382 if (LRECORD_FREE_P (SFTB_victim)) \ |
428 | 4383 { \ |
4384 num_free++; \ | |
4385 } \ | |
4386 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
4387 { \ | |
4388 num_used++; \ | |
4389 } \ | |
442 | 4390 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
428 | 4391 { \ |
4392 num_free++; \ | |
4393 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
4394 } \ | |
4395 else \ | |
4396 { \ | |
4397 num_used++; \ | |
4398 UNMARK_##typename (SFTB_victim); \ | |
4399 } \ | |
4400 } \ | |
4401 SFTB_current = SFTB_current->prev; \ | |
4402 SFTB_limit = countof (current_##typename##_block->block); \ | |
4403 } \ | |
4404 \ | |
4405 gc_count_num_##typename##_in_use = num_used; \ | |
4406 gc_count_num_##typename##_freelist = num_free; \ | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4407 COPY_INTO_LRECORD_STATS (typename); \ |
428 | 4408 } while (0) |
4409 | |
4410 #else /* !ERROR_CHECK_GC */ | |
4411 | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4412 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4413 do { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4414 struct typename##_block *SFTB_current; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4415 struct typename##_block **SFTB_prev; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4416 int SFTB_limit; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4417 int num_free = 0, num_used = 0; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4418 \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4419 typename##_free_list = 0; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4420 \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4421 for (SFTB_prev = ¤t_##typename##_block, \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4422 SFTB_current = current_##typename##_block, \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4423 SFTB_limit = current_##typename##_block_index; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4424 SFTB_current; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4425 ) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4426 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4427 int SFTB_iii; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4428 int SFTB_empty = 1; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4429 Lisp_Free *SFTB_old_free_list = typename##_free_list; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4430 \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4431 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4432 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4433 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4434 \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4435 if (LRECORD_FREE_P (SFTB_victim)) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4436 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4437 num_free++; \ |
771 | 4438 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4439 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4440 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4441 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4442 SFTB_empty = 0; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4443 num_used++; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4444 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4445 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4446 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4447 num_free++; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4448 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4449 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4450 else \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4451 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4452 SFTB_empty = 0; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4453 num_used++; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4454 UNMARK_##typename (SFTB_victim); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4455 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4456 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4457 if (!SFTB_empty) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4458 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4459 SFTB_prev = &(SFTB_current->prev); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4460 SFTB_current = SFTB_current->prev; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4461 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4462 else if (SFTB_current == current_##typename##_block \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4463 && !SFTB_current->prev) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4464 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4465 /* No real point in freeing sole allocation block */ \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4466 break; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4467 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4468 else \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4469 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4470 struct typename##_block *SFTB_victim_block = SFTB_current; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4471 if (SFTB_victim_block == current_##typename##_block) \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4472 current_##typename##_block_index \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4473 = countof (current_##typename##_block->block); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4474 SFTB_current = SFTB_current->prev; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4475 { \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4476 *SFTB_prev = SFTB_current; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4477 xfree (SFTB_victim_block); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4478 /* Restore free list to what it was before victim was swept */ \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4479 typename##_free_list = SFTB_old_free_list; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4480 num_free -= SFTB_limit; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4481 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4482 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4483 SFTB_limit = countof (current_##typename##_block->block); \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4484 } \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4485 \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4486 gc_count_num_##typename##_in_use = num_used; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4487 gc_count_num_##typename##_freelist = num_free; \ |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4488 COPY_INTO_LRECORD_STATS (typename); \ |
428 | 4489 } while (0) |
4490 | |
4491 #endif /* !ERROR_CHECK_GC */ | |
4492 | |
771 | 4493 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ |
4494 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader) | |
4495 | |
3263 | 4496 #endif /* not NEW_GC */ |
2720 | 4497 |
428 | 4498 |
3263 | 4499 #ifndef NEW_GC |
428 | 4500 static void |
4501 sweep_conses (void) | |
4502 { | |
4503 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4504 #define ADDITIONAL_FREE_cons(ptr) | |
4505 | |
440 | 4506 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons); |
428 | 4507 } |
3263 | 4508 #endif /* not NEW_GC */ |
428 | 4509 |
4510 /* Explicitly free a cons cell. */ | |
4511 void | |
853 | 4512 free_cons (Lisp_Object cons) |
428 | 4513 { |
3263 | 4514 #ifndef NEW_GC /* to avoid compiler warning */ |
853 | 4515 Lisp_Cons *ptr = XCONS (cons); |
3263 | 4516 #endif /* not NEW_GC */ |
853 | 4517 |
428 | 4518 #ifdef ERROR_CHECK_GC |
3263 | 4519 #ifdef NEW_GC |
2720 | 4520 Lisp_Cons *ptr = XCONS (cons); |
3263 | 4521 #endif /* NEW_GC */ |
428 | 4522 /* If the CAR is not an int, then it will be a pointer, which will |
4523 always be four-byte aligned. If this cons cell has already been | |
4524 placed on the free list, however, its car will probably contain | |
4525 a chain pointer to the next cons on the list, which has cleverly | |
4526 had all its 0's and 1's inverted. This allows for a quick | |
1204 | 4527 check to make sure we're not freeing something already freed. |
4528 | |
4529 NOTE: This check may not be necessary. Freeing an object sets its | |
4530 type to lrecord_type_free, which will trip up the XCONS() above -- as | |
4531 well as a check in FREE_FIXED_TYPE(). */ | |
853 | 4532 if (POINTER_TYPE_P (XTYPE (cons_car (ptr)))) |
4533 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr))); | |
428 | 4534 #endif /* ERROR_CHECK_GC */ |
4535 | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4536 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, cons, Lisp_Cons, ptr); |
428 | 4537 } |
4538 | |
4539 /* explicitly free a list. You **must make sure** that you have | |
4540 created all the cons cells that make up this list and that there | |
4541 are no pointers to any of these cons cells anywhere else. If there | |
4542 are, you will lose. */ | |
4543 | |
4544 void | |
4545 free_list (Lisp_Object list) | |
4546 { | |
4547 Lisp_Object rest, next; | |
4548 | |
4549 for (rest = list; !NILP (rest); rest = next) | |
4550 { | |
4551 next = XCDR (rest); | |
853 | 4552 free_cons (rest); |
428 | 4553 } |
4554 } | |
4555 | |
4556 /* explicitly free an alist. You **must make sure** that you have | |
4557 created all the cons cells that make up this alist and that there | |
4558 are no pointers to any of these cons cells anywhere else. If there | |
4559 are, you will lose. */ | |
4560 | |
4561 void | |
4562 free_alist (Lisp_Object alist) | |
4563 { | |
4564 Lisp_Object rest, next; | |
4565 | |
4566 for (rest = alist; !NILP (rest); rest = next) | |
4567 { | |
4568 next = XCDR (rest); | |
853 | 4569 free_cons (XCAR (rest)); |
4570 free_cons (rest); | |
428 | 4571 } |
4572 } | |
4573 | |
3263 | 4574 #ifndef NEW_GC |
428 | 4575 static void |
4576 sweep_compiled_functions (void) | |
4577 { | |
4578 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
945 | 4579 #define ADDITIONAL_FREE_compiled_function(ptr) \ |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4580 if (ptr->args_in_array) xfree (ptr->args) |
428 | 4581 |
4582 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); | |
4583 } | |
4584 | |
4585 static void | |
4586 sweep_floats (void) | |
4587 { | |
4588 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4589 #define ADDITIONAL_FREE_float(ptr) | |
4590 | |
440 | 4591 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); |
428 | 4592 } |
4593 | |
1983 | 4594 #ifdef HAVE_BIGNUM |
4595 static void | |
4596 sweep_bignums (void) | |
4597 { | |
4598 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4599 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) | |
4600 | |
4601 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); | |
4602 } | |
4603 #endif /* HAVE_BIGNUM */ | |
4604 | |
4605 #ifdef HAVE_RATIO | |
4606 static void | |
4607 sweep_ratios (void) | |
4608 { | |
4609 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4610 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) | |
4611 | |
4612 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); | |
4613 } | |
4614 #endif /* HAVE_RATIO */ | |
4615 | |
4616 #ifdef HAVE_BIGFLOAT | |
4617 static void | |
4618 sweep_bigfloats (void) | |
4619 { | |
4620 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4621 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) | |
4622 | |
4623 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); | |
4624 } | |
4625 #endif | |
4626 | |
428 | 4627 static void |
4628 sweep_symbols (void) | |
4629 { | |
4630 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4631 #define ADDITIONAL_FREE_symbol(ptr) | |
4632 | |
440 | 4633 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); |
428 | 4634 } |
4635 | |
4636 static void | |
4637 sweep_extents (void) | |
4638 { | |
4639 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4640 #define ADDITIONAL_FREE_extent(ptr) | |
4641 | |
4642 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); | |
4643 } | |
4644 | |
4645 static void | |
4646 sweep_events (void) | |
4647 { | |
4648 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4649 #define ADDITIONAL_FREE_event(ptr) | |
4650 | |
440 | 4651 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event); |
428 | 4652 } |
3263 | 4653 #endif /* not NEW_GC */ |
428 | 4654 |
1204 | 4655 #ifdef EVENT_DATA_AS_OBJECTS |
934 | 4656 |
3263 | 4657 #ifndef NEW_GC |
934 | 4658 static void |
4659 sweep_key_data (void) | |
4660 { | |
4661 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4662 #define ADDITIONAL_FREE_key_data(ptr) | |
4663 | |
4664 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data); | |
4665 } | |
3263 | 4666 #endif /* not NEW_GC */ |
934 | 4667 |
1204 | 4668 void |
4669 free_key_data (Lisp_Object ptr) | |
4670 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4671 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, key_data, Lisp_Key_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4672 XKEY_DATA (ptr)); |
2720 | 4673 } |
4674 | |
3263 | 4675 #ifndef NEW_GC |
934 | 4676 static void |
4677 sweep_button_data (void) | |
4678 { | |
4679 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4680 #define ADDITIONAL_FREE_button_data(ptr) | |
4681 | |
4682 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data); | |
4683 } | |
3263 | 4684 #endif /* not NEW_GC */ |
934 | 4685 |
1204 | 4686 void |
4687 free_button_data (Lisp_Object ptr) | |
4688 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4689 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, button_data, Lisp_Button_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4690 XBUTTON_DATA (ptr)); |
2720 | 4691 } |
4692 | |
3263 | 4693 #ifndef NEW_GC |
934 | 4694 static void |
4695 sweep_motion_data (void) | |
4696 { | |
4697 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4698 #define ADDITIONAL_FREE_motion_data(ptr) | |
4699 | |
4700 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data); | |
4701 } | |
3263 | 4702 #endif /* not NEW_GC */ |
934 | 4703 |
1204 | 4704 void |
4705 free_motion_data (Lisp_Object ptr) | |
4706 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4707 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, motion_data, Lisp_Motion_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4708 XMOTION_DATA (ptr)); |
2720 | 4709 } |
4710 | |
3263 | 4711 #ifndef NEW_GC |
934 | 4712 static void |
4713 sweep_process_data (void) | |
4714 { | |
4715 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4716 #define ADDITIONAL_FREE_process_data(ptr) | |
4717 | |
4718 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data); | |
4719 } | |
3263 | 4720 #endif /* not NEW_GC */ |
934 | 4721 |
1204 | 4722 void |
4723 free_process_data (Lisp_Object ptr) | |
4724 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4725 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, process_data, Lisp_Process_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4726 XPROCESS_DATA (ptr)); |
2720 | 4727 } |
4728 | |
3263 | 4729 #ifndef NEW_GC |
934 | 4730 static void |
4731 sweep_timeout_data (void) | |
4732 { | |
4733 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4734 #define ADDITIONAL_FREE_timeout_data(ptr) | |
4735 | |
4736 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data); | |
4737 } | |
3263 | 4738 #endif /* not NEW_GC */ |
934 | 4739 |
1204 | 4740 void |
4741 free_timeout_data (Lisp_Object ptr) | |
4742 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4743 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, timeout_data, Lisp_Timeout_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4744 XTIMEOUT_DATA (ptr)); |
2720 | 4745 } |
4746 | |
3263 | 4747 #ifndef NEW_GC |
934 | 4748 static void |
4749 sweep_magic_data (void) | |
4750 { | |
4751 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4752 #define ADDITIONAL_FREE_magic_data(ptr) | |
4753 | |
4754 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data); | |
4755 } | |
3263 | 4756 #endif /* not NEW_GC */ |
934 | 4757 |
1204 | 4758 void |
4759 free_magic_data (Lisp_Object ptr) | |
4760 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4761 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_data, Lisp_Magic_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4762 XMAGIC_DATA (ptr)); |
2720 | 4763 } |
4764 | |
3263 | 4765 #ifndef NEW_GC |
934 | 4766 static void |
4767 sweep_magic_eval_data (void) | |
4768 { | |
4769 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4770 #define ADDITIONAL_FREE_magic_eval_data(ptr) | |
4771 | |
4772 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data); | |
4773 } | |
3263 | 4774 #endif /* not NEW_GC */ |
934 | 4775 |
1204 | 4776 void |
4777 free_magic_eval_data (Lisp_Object ptr) | |
4778 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4779 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_eval_data, Lisp_Magic_Eval_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4780 XMAGIC_EVAL_DATA (ptr)); |
2720 | 4781 } |
4782 | |
3263 | 4783 #ifndef NEW_GC |
934 | 4784 static void |
4785 sweep_eval_data (void) | |
4786 { | |
4787 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4788 #define ADDITIONAL_FREE_eval_data(ptr) | |
4789 | |
4790 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data); | |
4791 } | |
3263 | 4792 #endif /* not NEW_GC */ |
934 | 4793 |
1204 | 4794 void |
4795 free_eval_data (Lisp_Object ptr) | |
4796 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4797 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, eval_data, Lisp_Eval_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4798 XEVAL_DATA (ptr)); |
2720 | 4799 } |
4800 | |
3263 | 4801 #ifndef NEW_GC |
934 | 4802 static void |
4803 sweep_misc_user_data (void) | |
4804 { | |
4805 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4806 #define ADDITIONAL_FREE_misc_user_data(ptr) | |
4807 | |
4808 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data); | |
4809 } | |
3263 | 4810 #endif /* not NEW_GC */ |
934 | 4811 |
1204 | 4812 void |
4813 free_misc_user_data (Lisp_Object ptr) | |
4814 { | |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4815 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, misc_user_data, Lisp_Misc_User_Data, |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4816 XMISC_USER_DATA (ptr)); |
1204 | 4817 } |
4818 | |
4819 #endif /* EVENT_DATA_AS_OBJECTS */ | |
934 | 4820 |
3263 | 4821 #ifndef NEW_GC |
428 | 4822 static void |
4823 sweep_markers (void) | |
4824 { | |
4825 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
4826 #define ADDITIONAL_FREE_marker(ptr) \ | |
4827 do { Lisp_Object tem; \ | |
793 | 4828 tem = wrap_marker (ptr); \ |
428 | 4829 unchain_marker (tem); \ |
4830 } while (0) | |
4831 | |
440 | 4832 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); |
428 | 4833 } |
3263 | 4834 #endif /* not NEW_GC */ |
428 | 4835 |
4836 /* Explicitly free a marker. */ | |
4837 void | |
1204 | 4838 free_marker (Lisp_Object ptr) |
428 | 4839 { |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
4840 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, marker, Lisp_Marker, XMARKER (ptr)); |
428 | 4841 } |
4842 | |
4843 | |
4844 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) | |
4845 | |
4846 static void | |
4847 verify_string_chars_integrity (void) | |
4848 { | |
4849 struct string_chars_block *sb; | |
4850 | |
4851 /* Scan each existing string block sequentially, string by string. */ | |
4852 for (sb = first_string_chars_block; sb; sb = sb->next) | |
4853 { | |
4854 int pos = 0; | |
4855 /* POS is the index of the next string in the block. */ | |
4856 while (pos < sb->pos) | |
4857 { | |
4858 struct string_chars *s_chars = | |
4859 (struct string_chars *) &(sb->string_chars[pos]); | |
438 | 4860 Lisp_String *string; |
428 | 4861 int size; |
4862 int fullsize; | |
4863 | |
454 | 4864 /* If the string_chars struct is marked as free (i.e. the |
4865 STRING pointer is NULL) then this is an unused chunk of | |
4866 string storage. (See below.) */ | |
4867 | |
4868 if (STRING_CHARS_FREE_P (s_chars)) | |
428 | 4869 { |
4870 fullsize = ((struct unused_string_chars *) s_chars)->fullsize; | |
4871 pos += fullsize; | |
4872 continue; | |
4873 } | |
4874 | |
4875 string = s_chars->string; | |
4876 /* Must be 32-bit aligned. */ | |
4877 assert ((((int) string) & 3) == 0); | |
4878 | |
793 | 4879 size = string->size_; |
428 | 4880 fullsize = STRING_FULLSIZE (size); |
4881 | |
4882 assert (!BIG_STRING_FULLSIZE_P (fullsize)); | |
2720 | 4883 assert (XSTRING_DATA (string) == s_chars->chars); |
428 | 4884 pos += fullsize; |
4885 } | |
4886 assert (pos == sb->pos); | |
4887 } | |
4888 } | |
4889 | |
1204 | 4890 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ |
428 | 4891 |
3092 | 4892 #ifndef NEW_GC |
428 | 4893 /* Compactify string chars, relocating the reference to each -- |
4894 free any empty string_chars_block we see. */ | |
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
4895 static void |
428 | 4896 compact_string_chars (void) |
4897 { | |
4898 struct string_chars_block *to_sb = first_string_chars_block; | |
4899 int to_pos = 0; | |
4900 struct string_chars_block *from_sb; | |
4901 | |
4902 /* Scan each existing string block sequentially, string by string. */ | |
4903 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next) | |
4904 { | |
4905 int from_pos = 0; | |
4906 /* FROM_POS is the index of the next string in the block. */ | |
4907 while (from_pos < from_sb->pos) | |
4908 { | |
4909 struct string_chars *from_s_chars = | |
4910 (struct string_chars *) &(from_sb->string_chars[from_pos]); | |
4911 struct string_chars *to_s_chars; | |
438 | 4912 Lisp_String *string; |
428 | 4913 int size; |
4914 int fullsize; | |
4915 | |
454 | 4916 /* If the string_chars struct is marked as free (i.e. the |
4917 STRING pointer is NULL) then this is an unused chunk of | |
4918 string storage. This happens under Mule when a string's | |
4919 size changes in such a way that its fullsize changes. | |
4920 (Strings can change size because a different-length | |
4921 character can be substituted for another character.) | |
4922 In this case, after the bogus string pointer is the | |
4923 "fullsize" of this entry, i.e. how many bytes to skip. */ | |
4924 | |
4925 if (STRING_CHARS_FREE_P (from_s_chars)) | |
428 | 4926 { |
4927 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize; | |
4928 from_pos += fullsize; | |
4929 continue; | |
4930 } | |
4931 | |
4932 string = from_s_chars->string; | |
1204 | 4933 gc_checking_assert (!(LRECORD_FREE_P (string))); |
428 | 4934 |
793 | 4935 size = string->size_; |
428 | 4936 fullsize = STRING_FULLSIZE (size); |
4937 | |
442 | 4938 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); |
428 | 4939 |
4940 /* Just skip it if it isn't marked. */ | |
771 | 4941 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader))) |
428 | 4942 { |
4943 from_pos += fullsize; | |
4944 continue; | |
4945 } | |
4946 | |
4947 /* If it won't fit in what's left of TO_SB, close TO_SB out | |
4948 and go on to the next string_chars_block. We know that TO_SB | |
4949 cannot advance past FROM_SB here since FROM_SB is large enough | |
4950 to currently contain this string. */ | |
4951 if ((to_pos + fullsize) > countof (to_sb->string_chars)) | |
4952 { | |
4953 to_sb->pos = to_pos; | |
4954 to_sb = to_sb->next; | |
4955 to_pos = 0; | |
4956 } | |
4957 | |
4958 /* Compute new address of this string | |
4959 and update TO_POS for the space being used. */ | |
4960 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]); | |
4961 | |
4962 /* Copy the string_chars to the new place. */ | |
4963 if (from_s_chars != to_s_chars) | |
4964 memmove (to_s_chars, from_s_chars, fullsize); | |
4965 | |
4966 /* Relocate FROM_S_CHARS's reference */ | |
826 | 4967 set_lispstringp_data (string, &(to_s_chars->chars[0])); |
428 | 4968 |
4969 from_pos += fullsize; | |
4970 to_pos += fullsize; | |
4971 } | |
4972 } | |
4973 | |
4974 /* Set current to the last string chars block still used and | |
4975 free any that follow. */ | |
4976 { | |
4977 struct string_chars_block *victim; | |
4978 | |
4979 for (victim = to_sb->next; victim; ) | |
4980 { | |
4981 struct string_chars_block *next = victim->next; | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4969
diff
changeset
|
4982 xfree (victim); |
428 | 4983 victim = next; |
4984 } | |
4985 | |
4986 current_string_chars_block = to_sb; | |
4987 current_string_chars_block->pos = to_pos; | |
4988 current_string_chars_block->next = 0; | |
4989 } | |
4990 } | |
3092 | 4991 #endif /* not NEW_GC */ |
428 | 4992 |
3263 | 4993 #ifndef NEW_GC |
428 | 4994 #if 1 /* Hack to debug missing purecopy's */ |
4995 static int debug_string_purity; | |
4996 | |
4997 static void | |
793 | 4998 debug_string_purity_print (Lisp_Object p) |
428 | 4999 { |
5000 Charcount i; | |
826 | 5001 Charcount s = string_char_length (p); |
442 | 5002 stderr_out ("\""); |
428 | 5003 for (i = 0; i < s; i++) |
5004 { | |
867 | 5005 Ichar ch = string_ichar (p, i); |
428 | 5006 if (ch < 32 || ch >= 126) |
5007 stderr_out ("\\%03o", ch); | |
5008 else if (ch == '\\' || ch == '\"') | |
5009 stderr_out ("\\%c", ch); | |
5010 else | |
5011 stderr_out ("%c", ch); | |
5012 } | |
5013 stderr_out ("\"\n"); | |
5014 } | |
5015 #endif /* 1 */ | |
3263 | 5016 #endif /* not NEW_GC */ |
5017 | |
5018 #ifndef NEW_GC | |
428 | 5019 static void |
5020 sweep_strings (void) | |
5021 { | |
5022 int debug = debug_string_purity; | |
5023 | |
793 | 5024 #define UNMARK_string(ptr) do { \ |
5025 Lisp_String *p = (ptr); \ | |
5026 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ | |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5027 tick_string_stats (p, 1); \ |
793 | 5028 if (debug) \ |
5029 debug_string_purity_print (wrap_string (p)); \ | |
438 | 5030 } while (0) |
5031 #define ADDITIONAL_FREE_string(ptr) do { \ | |
793 | 5032 Bytecount size = ptr->size_; \ |
438 | 5033 if (BIG_STRING_SIZE_P (size)) \ |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
5034 xfree (ptr->data_); \ |
438 | 5035 } while (0) |
5036 | |
771 | 5037 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); |
428 | 5038 } |
3263 | 5039 #endif /* not NEW_GC */ |
428 | 5040 |
3092 | 5041 #ifndef NEW_GC |
5042 void | |
5043 gc_sweep_1 (void) | |
428 | 5044 { |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
5045 /* Reset all statistics to 0. They will be incremented when |
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
5046 sweeping lcrecords, frob-block lrecords and dumped objects. */ |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5047 clear_lrecord_stats (); |
5059
c8f90d61dcf3
fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents:
5058
diff
changeset
|
5048 |
428 | 5049 /* Free all unmarked records. Do this at the very beginning, |
5050 before anything else, so that the finalize methods can safely | |
5051 examine items in the objects. sweep_lcrecords_1() makes | |
5052 sure to call all the finalize methods *before* freeing anything, | |
5053 to complete the safety. */ | |
5054 { | |
5055 int ignored; | |
5056 sweep_lcrecords_1 (&all_lcrecords, &ignored); | |
5057 } | |
5058 | |
5059 compact_string_chars (); | |
5060 | |
5061 /* Finalize methods below (called through the ADDITIONAL_FREE_foo | |
5062 macros) must be *extremely* careful to make sure they're not | |
5063 referencing freed objects. The only two existing finalize | |
5064 methods (for strings and markers) pass muster -- the string | |
5065 finalizer doesn't look at anything but its own specially- | |
5066 created block, and the marker finalizer only looks at live | |
5067 buffers (which will never be freed) and at the markers before | |
5068 and after it in the chain (which, by induction, will never be | |
5069 freed because if so, they would have already removed themselves | |
5070 from the chain). */ | |
5071 | |
5072 /* Put all unmarked strings on free list, free'ing the string chars | |
5073 of large unmarked strings */ | |
5074 sweep_strings (); | |
5075 | |
5076 /* Put all unmarked conses on free list */ | |
5077 sweep_conses (); | |
5078 | |
5079 /* Free all unmarked compiled-function objects */ | |
5080 sweep_compiled_functions (); | |
5081 | |
5082 /* Put all unmarked floats on free list */ | |
5083 sweep_floats (); | |
5084 | |
1983 | 5085 #ifdef HAVE_BIGNUM |
5086 /* Put all unmarked bignums on free list */ | |
5087 sweep_bignums (); | |
5088 #endif | |
5089 | |
5090 #ifdef HAVE_RATIO | |
5091 /* Put all unmarked ratios on free list */ | |
5092 sweep_ratios (); | |
5093 #endif | |
5094 | |
5095 #ifdef HAVE_BIGFLOAT | |
5096 /* Put all unmarked bigfloats on free list */ | |
5097 sweep_bigfloats (); | |
5098 #endif | |
5099 | |
428 | 5100 /* Put all unmarked symbols on free list */ |
5101 sweep_symbols (); | |
5102 | |
5103 /* Put all unmarked extents on free list */ | |
5104 sweep_extents (); | |
5105 | |
5106 /* Put all unmarked markers on free list. | |
5107 Dechain each one first from the buffer into which it points. */ | |
5108 sweep_markers (); | |
5109 | |
5110 sweep_events (); | |
5111 | |
1204 | 5112 #ifdef EVENT_DATA_AS_OBJECTS |
934 | 5113 sweep_key_data (); |
5114 sweep_button_data (); | |
5115 sweep_motion_data (); | |
5116 sweep_process_data (); | |
5117 sweep_timeout_data (); | |
5118 sweep_magic_data (); | |
5119 sweep_magic_eval_data (); | |
5120 sweep_eval_data (); | |
5121 sweep_misc_user_data (); | |
1204 | 5122 #endif /* EVENT_DATA_AS_OBJECTS */ |
5158
9e0b43d3095c
more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents:
5157
diff
changeset
|
5123 |
428 | 5124 #ifdef PDUMP |
442 | 5125 pdump_objects_unmark (); |
428 | 5126 #endif |
5127 } | |
3092 | 5128 #endif /* not NEW_GC */ |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5129 |
428 | 5130 |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5131 /************************************************************************/ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5132 /* "Disksave Finalization" -- Preparing for Dumping */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5133 /************************************************************************/ |
428 | 5134 |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5135 static void |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5136 disksave_object_finalization_1 (void) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5137 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5138 #ifdef NEW_GC |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5139 mc_finalize_for_disksave (); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5140 #else /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5141 struct old_lcrecord_header *header; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5142 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5143 for (header = all_lcrecords; header; header = header->next) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5144 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5145 struct lrecord_header *objh = &header->lheader; |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5146 const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5147 #if 0 /* possibly useful for debugging */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5148 if (!RECORD_DUMPABLE (objh) && !objh->free) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5149 { |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5150 stderr_out ("Disksaving a non-dumpable object: "); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5151 debug_print (wrap_pointer_1 (header)); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5152 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5153 #endif |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5154 if (imp->disksave && !objh->free) |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5155 (imp->disksave) (wrap_pointer_1 (header)); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5156 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5157 #endif /* not NEW_GC */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5158 } |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5159 |
428 | 5160 void |
5161 disksave_object_finalization (void) | |
5162 { | |
5163 /* It's important that certain information from the environment not get | |
5164 dumped with the executable (pathnames, environment variables, etc.). | |
5165 To make it easier to tell when this has happened with strings(1) we | |
5166 clear some known-to-be-garbage blocks of memory, so that leftover | |
5167 results of old evaluation don't look like potential problems. | |
5168 But first we set some notable variables to nil and do one more GC, | |
5169 to turn those strings into garbage. | |
440 | 5170 */ |
428 | 5171 |
5172 /* Yeah, this list is pretty ad-hoc... */ | |
5173 Vprocess_environment = Qnil; | |
771 | 5174 env_initted = 0; |
428 | 5175 Vexec_directory = Qnil; |
5176 Vdata_directory = Qnil; | |
5177 Vsite_directory = Qnil; | |
5178 Vdoc_directory = Qnil; | |
5179 Vexec_path = Qnil; | |
5180 Vload_path = Qnil; | |
5181 /* Vdump_load_path = Qnil; */ | |
5182 /* Release hash tables for locate_file */ | |
5183 Flocate_file_clear_hashing (Qt); | |
771 | 5184 uncache_home_directory (); |
776 | 5185 zero_out_command_line_status_vars (); |
872 | 5186 clear_default_devices (); |
428 | 5187 |
5188 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \ | |
5189 defined(LOADHIST_BUILTIN)) | |
5190 Vload_history = Qnil; | |
5191 #endif | |
5192 Vshell_file_name = Qnil; | |
5193 | |
3092 | 5194 #ifdef NEW_GC |
5195 gc_full (); | |
5196 #else /* not NEW_GC */ | |
428 | 5197 garbage_collect_1 (); |
3092 | 5198 #endif /* not NEW_GC */ |
428 | 5199 |
5200 /* Run the disksave finalization methods of all live objects. */ | |
5201 disksave_object_finalization_1 (); | |
5202 | |
3092 | 5203 #ifndef NEW_GC |
428 | 5204 /* Zero out the uninitialized (really, unused) part of the containers |
5205 for the live strings. */ | |
5206 { | |
5207 struct string_chars_block *scb; | |
5208 for (scb = first_string_chars_block; scb; scb = scb->next) | |
5209 { | |
5210 int count = sizeof (scb->string_chars) - scb->pos; | |
5211 | |
5212 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); | |
440 | 5213 if (count != 0) |
5214 { | |
5215 /* from the block's fill ptr to the end */ | |
5216 memset ((scb->string_chars + scb->pos), 0, count); | |
5217 } | |
428 | 5218 } |
5219 } | |
3092 | 5220 #endif /* not NEW_GC */ |
428 | 5221 |
5222 /* There, that ought to be enough... */ | |
5223 | |
5224 } | |
5225 | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5226 |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5227 /************************************************************************/ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5228 /* Lisp interface onto garbage collection */ |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5229 /************************************************************************/ |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5230 |
2994 | 5231 /* Debugging aids. */ |
5232 | |
5233 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
5234 Reclaim storage for Lisp objects no longer needed. | |
5235 Return info on amount of space in use: | |
5236 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) | |
5237 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
5238 PLIST) | |
5239 where `PLIST' is a list of alternating keyword/value pairs providing | |
5240 more detailed information. | |
5241 Garbage collection happens automatically if you cons more than | |
5242 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
5243 */ | |
5244 ()) | |
5245 { | |
5246 /* Record total usage for purposes of determining next GC */ | |
3092 | 5247 #ifdef NEW_GC |
5248 gc_full (); | |
5249 #else /* not NEW_GC */ | |
2994 | 5250 garbage_collect_1 (); |
3092 | 5251 #endif /* not NEW_GC */ |
2994 | 5252 |
5253 /* This will get set to 1, and total_gc_usage computed, as part of the | |
5254 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */ | |
5255 total_gc_usage_set = 0; | |
5256 #ifdef ALLOC_TYPE_STATS | |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5257 return garbage_collection_statistics (); |
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5258 #else |
2994 | 5259 return Qnil; |
5167
e374ea766cc1
clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents:
5160
diff
changeset
|
5260 #endif |
2994 | 5261 } |
428 | 5262 |
5263 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* | |
5264 Return the number of bytes consed since the last garbage collection. | |
5265 \"Consed\" is a misnomer in that this actually counts allocation | |
5266 of all different kinds of objects, not just conses. | |
5267 | |
5268 If this value exceeds `gc-cons-threshold', a garbage collection happens. | |
5269 */ | |
5270 ()) | |
5271 { | |
5272 return make_int (consing_since_gc); | |
5273 } | |
5274 | |
440 | 5275 #if 0 |
444 | 5276 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /* |
801 | 5277 Return the address of the last byte XEmacs has allocated, divided by 1024. |
5278 This may be helpful in debugging XEmacs's memory usage. | |
428 | 5279 The value is divided by 1024 to make sure it will fit in a lisp integer. |
5280 */ | |
5281 ()) | |
5282 { | |
5283 return make_int ((EMACS_INT) sbrk (0) / 1024); | |
5284 } | |
440 | 5285 #endif |
428 | 5286 |
2994 | 5287 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /* |
801 | 5288 Return the total number of bytes used by the data segment in XEmacs. |
5289 This may be helpful in debugging XEmacs's memory usage. | |
2994 | 5290 NOTE: This may or may not be accurate! It is hard to determine this |
5291 value in a system-independent fashion. On Windows, for example, the | |
5292 returned number tends to be much greater than reality. | |
801 | 5293 */ |
5294 ()) | |
5295 { | |
5296 return make_int (total_data_usage ()); | |
5297 } | |
5298 | |
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5299 #ifdef USE_VALGRIND |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5300 DEFUN ("valgrind-leak-check", Fvalgrind_leak_check, 0, 0, "", /* |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5301 Ask valgrind to perform a memory leak check. |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5302 The results of the leak check are sent to stderr. |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5303 */ |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5304 ()) |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5305 { |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5306 VALGRIND_DO_LEAK_CHECK; |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5307 return Qnil; |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5308 } |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5309 |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5310 DEFUN ("valgrind-quick-leak-check", Fvalgrind_quick_leak_check, 0, 0, "", /* |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5311 Ask valgrind to perform a quick memory leak check. |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5312 This just prints a summary of leaked memory, rather than all the details. |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5313 The results of the leak check are sent to stderr. |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5314 */ |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5315 ()) |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5316 { |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5317 VALGRIND_DO_QUICK_LEAK_CHECK; |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5318 return Qnil; |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5319 } |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5320 #endif /* USE_VALGRIND */ |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5321 |
428 | 5322 |
5160
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5323 /************************************************************************/ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5324 /* Initialization */ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5325 /************************************************************************/ |
ab9ee10a53e4
fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents:
5159
diff
changeset
|
5326 |
428 | 5327 /* Initialization */ |
771 | 5328 static void |
1204 | 5329 common_init_alloc_early (void) |
428 | 5330 { |
771 | 5331 #ifndef Qzero |
5332 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ | |
5333 #endif | |
5334 | |
5335 #ifndef Qnull_pointer | |
5336 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, | |
5337 so the following is actually a no-op. */ | |
793 | 5338 Qnull_pointer = wrap_pointer_1 (0); |
771 | 5339 #endif |
5340 | |
3263 | 5341 #ifndef NEW_GC |
428 | 5342 breathing_space = 0; |
5343 all_lcrecords = 0; | |
3263 | 5344 #endif /* not NEW_GC */ |
428 | 5345 ignore_malloc_warnings = 1; |
5346 #ifdef DOUG_LEA_MALLOC | |
5347 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ | |
5348 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ | |
5349 #if 0 /* Moved to emacs.c */ | |
5350 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ | |
5351 #endif | |
5352 #endif | |
3092 | 5353 #ifndef NEW_GC |
2720 | 5354 init_string_chars_alloc (); |
428 | 5355 init_string_alloc (); |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5356 /* #### Is it intentional that this is called twice? --ben */ |
428 | 5357 init_string_chars_alloc (); |
5358 init_cons_alloc (); | |
5359 init_symbol_alloc (); | |
5360 init_compiled_function_alloc (); | |
5361 init_float_alloc (); | |
1983 | 5362 #ifdef HAVE_BIGNUM |
5363 init_bignum_alloc (); | |
5364 #endif | |
5365 #ifdef HAVE_RATIO | |
5366 init_ratio_alloc (); | |
5367 #endif | |
5368 #ifdef HAVE_BIGFLOAT | |
5369 init_bigfloat_alloc (); | |
5370 #endif | |
428 | 5371 init_marker_alloc (); |
5372 init_extent_alloc (); | |
5373 init_event_alloc (); | |
1204 | 5374 #ifdef EVENT_DATA_AS_OBJECTS |
934 | 5375 init_key_data_alloc (); |
5376 init_button_data_alloc (); | |
5377 init_motion_data_alloc (); | |
5378 init_process_data_alloc (); | |
5379 init_timeout_data_alloc (); | |
5380 init_magic_data_alloc (); | |
5381 init_magic_eval_data_alloc (); | |
5382 init_eval_data_alloc (); | |
5383 init_misc_user_data_alloc (); | |
1204 | 5384 #endif /* EVENT_DATA_AS_OBJECTS */ |
3263 | 5385 #endif /* not NEW_GC */ |
428 | 5386 |
5387 ignore_malloc_warnings = 0; | |
5388 | |
452 | 5389 if (staticpros_nodump) |
5390 Dynarr_free (staticpros_nodump); | |
5391 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); | |
5392 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */ | |
771 | 5393 #ifdef DEBUG_XEMACS |
5394 if (staticpro_nodump_names) | |
5395 Dynarr_free (staticpro_nodump_names); | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5396 staticpro_nodump_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5397 const Ascbyte *); |
771 | 5398 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */ |
5399 #endif | |
428 | 5400 |
3263 | 5401 #ifdef NEW_GC |
2720 | 5402 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
5403 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
5404 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
5405 #ifdef DEBUG_XEMACS | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5406 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
2720 | 5407 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5408 dump_add_root_block_ptr (&mcpro_names, |
4964 | 5409 &const_Ascbyte_ptr_dynarr_description); |
2720 | 5410 #endif |
3263 | 5411 #endif /* NEW_GC */ |
2720 | 5412 |
428 | 5413 consing_since_gc = 0; |
851 | 5414 need_to_check_c_alloca = 0; |
5415 funcall_allocation_flag = 0; | |
5416 funcall_alloca_count = 0; | |
814 | 5417 |
3263 | 5418 #ifndef NEW_GC |
428 | 5419 debug_string_purity = 0; |
3263 | 5420 #endif /* not NEW_GC */ |
428 | 5421 |
800 | 5422 #ifdef ERROR_CHECK_TYPES |
428 | 5423 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = |
5424 666; | |
5425 ERROR_ME_NOT. | |
5426 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; | |
5427 ERROR_ME_WARN. | |
5428 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
5429 3333632; | |
793 | 5430 ERROR_ME_DEBUG_WARN. |
5431 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
5432 8675309; | |
800 | 5433 #endif /* ERROR_CHECK_TYPES */ |
428 | 5434 } |
5435 | |
3263 | 5436 #ifndef NEW_GC |
771 | 5437 static void |
5438 init_lcrecord_lists (void) | |
5439 { | |
5440 int i; | |
5441 | |
5442 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
5443 { | |
5444 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */ | |
5445 staticpro_nodump (&all_lcrecord_lists[i]); | |
5446 } | |
5447 } | |
3263 | 5448 #endif /* not NEW_GC */ |
771 | 5449 |
5450 void | |
1204 | 5451 init_alloc_early (void) |
771 | 5452 { |
1204 | 5453 #if defined (__cplusplus) && defined (ERROR_CHECK_GC) |
5454 static struct gcpro initial_gcpro; | |
5455 | |
5456 initial_gcpro.next = 0; | |
5457 initial_gcpro.var = &Qnil; | |
5458 initial_gcpro.nvars = 1; | |
5459 gcprolist = &initial_gcpro; | |
5460 #else | |
5461 gcprolist = 0; | |
5462 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ | |
5463 } | |
5464 | |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5465 static void |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5466 reinit_alloc_objects_early (void) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5467 { |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5468 OBJECT_HAS_METHOD (string, getprop); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5469 OBJECT_HAS_METHOD (string, putprop); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5470 OBJECT_HAS_METHOD (string, remprop); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5471 OBJECT_HAS_METHOD (string, plist); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5472 } |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5473 |
1204 | 5474 void |
5475 reinit_alloc_early (void) | |
5476 { | |
5477 common_init_alloc_early (); | |
3263 | 5478 #ifndef NEW_GC |
771 | 5479 init_lcrecord_lists (); |
3263 | 5480 #endif /* not NEW_GC */ |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5481 reinit_alloc_objects_early (); |
771 | 5482 } |
5483 | |
428 | 5484 void |
5485 init_alloc_once_early (void) | |
5486 { | |
1204 | 5487 common_init_alloc_early (); |
428 | 5488 |
442 | 5489 { |
5490 int i; | |
5491 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
5492 lrecord_implementations_table[i] = 0; | |
5493 } | |
5494 | |
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
5495 dump_add_opaque (lrecord_uid_counter, sizeof (lrecord_uid_counter)); |
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
5496 |
452 | 5497 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); |
5498 Dynarr_resize (staticpros, 1410); /* merely a small optimization */ | |
2367 | 5499 dump_add_root_block_ptr (&staticpros, &staticpros_description); |
771 | 5500 #ifdef DEBUG_XEMACS |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5501 staticpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
771 | 5502 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5503 dump_add_root_block_ptr (&staticpro_names, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5504 &const_Ascbyte_ptr_dynarr_description); |
771 | 5505 #endif |
5506 | |
3263 | 5507 #ifdef NEW_GC |
2720 | 5508 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); |
5509 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
5510 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
5511 #ifdef DEBUG_XEMACS | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5512 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *); |
2720 | 5513 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5514 dump_add_root_block_ptr (&mcpro_names, |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4938
diff
changeset
|
5515 &const_Ascbyte_ptr_dynarr_description); |
2720 | 5516 #endif |
3263 | 5517 #else /* not NEW_GC */ |
771 | 5518 init_lcrecord_lists (); |
3263 | 5519 #endif /* not NEW_GC */ |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5520 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5521 INIT_LISP_OBJECT (cons); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5522 INIT_LISP_OBJECT (vector); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5523 INIT_LISP_OBJECT (string); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5524 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5525 #ifdef NEW_GC |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5526 INIT_LISP_OBJECT (string_indirect_data); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5527 INIT_LISP_OBJECT (string_direct_data); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5528 #endif /* NEW_GC */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5529 #ifndef NEW_GC |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5530 INIT_LISP_OBJECT (lcrecord_list); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5531 INIT_LISP_OBJECT (free); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5532 #endif /* not NEW_GC */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5533 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5534 reinit_alloc_objects_early (); |
428 | 5535 } |
5536 | |
5537 void | |
5538 syms_of_alloc (void) | |
5539 { | |
442 | 5540 DEFSYMBOL (Qgarbage_collecting); |
428 | 5541 |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5542 #ifdef MEMORY_USAGE_STATS |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5543 DEFSYMBOL (Qobject_actually_requested); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5544 DEFSYMBOL (Qobject_malloc_overhead); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5545 DEFSYMBOL (Qother_memory_actually_requested); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5546 DEFSYMBOL (Qother_memory_malloc_overhead); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5547 DEFSYMBOL (Qother_memory_dynarr_overhead); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5548 DEFSYMBOL (Qother_memory_gap_overhead); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5549 #endif /* MEMORY_USAGE_STATS */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5550 |
428 | 5551 DEFSUBR (Fcons); |
5552 DEFSUBR (Flist); | |
5553 DEFSUBR (Fvector); | |
5554 DEFSUBR (Fbit_vector); | |
5555 DEFSUBR (Fmake_byte_code); | |
5556 DEFSUBR (Fmake_list); | |
5557 DEFSUBR (Fmake_vector); | |
5558 DEFSUBR (Fmake_bit_vector); | |
5559 DEFSUBR (Fmake_string); | |
5560 DEFSUBR (Fstring); | |
5561 DEFSUBR (Fmake_symbol); | |
5562 DEFSUBR (Fmake_marker); | |
5563 DEFSUBR (Fpurecopy); | |
2994 | 5564 #ifdef ALLOC_TYPE_STATS |
5565 DEFSUBR (Fobject_memory_usage_stats); | |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5566 DEFSUBR (Ftotal_object_memory_usage); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5567 #endif /* ALLOC_TYPE_STATS */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5568 #ifdef MEMORY_USAGE_STATS |
2994 | 5569 DEFSUBR (Fobject_memory_usage); |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5570 #endif /* MEMORY_USAGE_STATS */ |
428 | 5571 DEFSUBR (Fgarbage_collect); |
440 | 5572 #if 0 |
428 | 5573 DEFSUBR (Fmemory_limit); |
440 | 5574 #endif |
2994 | 5575 DEFSUBR (Ftotal_memory_usage); |
428 | 5576 DEFSUBR (Fconsing_since_gc); |
4803
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5577 #ifdef USE_VALGRIND |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5578 DEFSUBR (Fvalgrind_leak_check); |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5579 DEFSUBR (Fvalgrind_quick_leak_check); |
5d120deb60ca
Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents:
4776
diff
changeset
|
5580 #endif |
428 | 5581 } |
5582 | |
5583 void | |
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5584 reinit_vars_of_alloc (void) |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5585 { |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5586 #ifdef MEMORY_USAGE_STATS |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5587 compute_memusage_stats_length (); |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5588 #endif /* MEMORY_USAGE_STATS */ |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5589 } |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5590 |
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5146
diff
changeset
|
5591 void |
428 | 5592 vars_of_alloc (void) |
5593 { | |
5594 #ifdef DEBUG_XEMACS | |
5595 DEFVAR_INT ("debug-allocation", &debug_allocation /* | |
5596 If non-zero, print out information to stderr about all objects allocated. | |
5597 See also `debug-allocation-backtrace-length'. | |
5598 */ ); | |
5599 debug_allocation = 0; | |
5600 | |
5601 DEFVAR_INT ("debug-allocation-backtrace-length", | |
5602 &debug_allocation_backtrace_length /* | |
5603 Length (in stack frames) of short backtrace printed out by `debug-allocation'. | |
5604 */ ); | |
5605 debug_allocation_backtrace_length = 2; | |
5606 #endif | |
5607 | |
5608 DEFVAR_BOOL ("purify-flag", &purify_flag /* | |
5609 Non-nil means loading Lisp code in order to dump an executable. | |
5610 This means that certain objects should be allocated in readonly space. | |
5611 */ ); | |
5612 } |