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