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