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