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