annotate src/alloc.c @ 5167:e374ea766cc1

clean up, rearrange allocation statistics code -------------------- ChangeLog entries follow: -------------------- src/ChangeLog addition: 2010-03-21 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (assert_proper_sizing): * alloc.c (c_readonly): * alloc.c (malloced_storage_size): * alloc.c (fixed_type_block_overhead): * alloc.c (lisp_object_storage_size): * alloc.c (inc_lrecord_stats): * alloc.c (dec_lrecord_stats): * alloc.c (pluralize_word): * alloc.c (object_memory_usage_stats): * alloc.c (Fobject_memory_usage): * alloc.c (compute_memusage_stats_length): * alloc.c (disksave_object_finalization_1): * alloc.c (Fgarbage_collect): * mc-alloc.c: * mc-alloc.c (mc_alloced_storage_size): * mc-alloc.h: No functionality change here. Collect the allocations-statistics code that was scattered throughout alloc.c into one place. Add remaining section headings so that all sections have headings clearly identifying the start of the section and its purpose. Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS; this fixes build problems and is related to the export of lisp_object_storage_size() and malloced_storage_size() when non-MEMORY_USAGE_STATS in the previous change set.
author Ben Wing <ben@xemacs.org>
date Sun, 21 Mar 2010 04:41:49 -0500
parents ab9ee10a53e4
children 5ddbab03b0e6
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Storage allocation and gc for XEmacs Lisp interpreter.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 FSF. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* Authorship:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 FSF: Original version; a long time ago.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 Mly: Significantly rewritten to use new 3-bit tags and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 nicely abstracted object definitions, for 19.8.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 JWZ: Improved code to keep track of purespace usage and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 issue nice purespace and GC stats.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 and various changes for Mule, for 19.12.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 Added bit vectors for 19.13.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 Added lcrecord lists for 19.14.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 slb: Lots of work on the purification and dump time code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 Synched Doug Lea malloc support from Emacs 20.2.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 #include "backtrace.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 #include "chartab.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "device.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "elhash.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 #include "events.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
52 #include "extents-impl.h"
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
53 #include "file-coding.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
54 #include "frame-impl.h"
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
55 #include "gc.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #include "glyphs.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #include "opaque.h"
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
58 #include "lstream.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
59 #include "process.h"
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
60 #include "profile.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #include "redisplay.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 #include "specifier.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 #include "sysfile.h"
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
64 #include "sysdep.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #include "window.h"
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
66 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
67 #include "vdb.h"
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
68 #endif /* NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 #include "console-stream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 #include <malloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 #endif
4803
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
74 #ifdef USE_VALGRIND
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
75 #include <valgrind/memcheck.h>
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
76 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 EXFUN (Fgarbage_collect, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 #if 0 /* this is _way_ too slow to be part of the standard debug options */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 #if defined(DEBUG_XEMACS) && defined(MULE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 #define VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 /* Define this to use malloc/free with no freelist for all datatypes,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 the hope being that some debugging tools may help detect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 freed memory references */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 #include <dmalloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 #define ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 #ifdef DEBUG_XEMACS
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
95 static Fixnum debug_allocation;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
96 static Fixnum debug_allocation_backtrace_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
99 int need_to_check_c_alloca;
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
100 int need_to_signal_post_gc;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
101 int funcall_allocation_flag;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
102 Bytecount __temp_alloca_size__;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
103 Bytecount funcall_alloca_count;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
104
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
105 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
106 Additional ones may be defined by a module (none yet). We leave some
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
107 room in `lrecord_implementations_table' for such new lisp object types. */
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
108 struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
109 int lrecord_type_count = lrecord_type_last_built_in_type;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
110
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
111 /* This is just for use by the printer, to allow things to print uniquely.
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
112 We have a separate UID space for each object. (Important because the
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
113 UID is only 20 bits in old-GC, and 22 in NEW_GC.) */
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
114 int lrecord_uid_counter[countof (lrecord_implementations_table)];
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
115
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
116 #ifndef USE_KKCC
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
117 /* Object marker functions are in the lrecord_implementation structure.
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
118 But copying them to a parallel array is much more cache-friendly.
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
119 This hack speeds up (garbage-collect) by about 5%. */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
120 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
121 #endif /* not USE_KKCC */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
122
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
123 struct gcpro *gcprolist;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
124
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
125 /* Non-zero means we're in the process of doing the dump */
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
126 int purify_flag;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
127
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
128 /* Non-zero means we're pdumping out or in */
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
129 #ifdef PDUMP
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
130 int in_pdump;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
131 #endif
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
132
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
133 #ifdef ERROR_CHECK_TYPES
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
134
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
135 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
136
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
137 #endif
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
138
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
139 #ifdef MEMORY_USAGE_STATS
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
140 Lisp_Object Qobject_actually_requested, Qobject_malloc_overhead;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
141 Lisp_Object Qother_memory_actually_requested, Qother_memory_malloc_overhead;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
142 Lisp_Object Qother_memory_dynarr_overhead, Qother_memory_gap_overhead;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
143 #endif /* MEMORY_USAGE_STATS */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
144
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
145 #ifndef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
146 static int gc_count_num_short_string_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
147 static Bytecount gc_count_string_total_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
148 static Bytecount gc_count_short_string_total_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
149 static Bytecount gc_count_long_string_storage_including_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
150 #endif /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
151
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
152 /* static int gc_count_total_records_used, gc_count_records_total_size; */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
153
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
154 /* stats on objects in use */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
155
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
156 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
157
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
158 static struct
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
159 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
160 int instances_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
161 int bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
162 int bytes_in_use_including_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
163 } lrecord_stats [countof (lrecord_implementations_table)];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
164
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
165 #else /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
166
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
167 static struct
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
168 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
169 Elemcount instances_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
170 Bytecount bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
171 Bytecount bytes_in_use_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
172 Elemcount instances_freed;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
173 Bytecount bytes_freed;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
174 Bytecount bytes_freed_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
175 Elemcount instances_on_free_list;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
176 Bytecount bytes_on_free_list;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
177 Bytecount bytes_on_free_list_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
178 #ifdef MEMORY_USAGE_STATS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
179 Bytecount nonlisp_bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
180 struct generic_usage_stats stats;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
181 #endif
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
182 } lrecord_stats [countof (lrecord_implementations_table)];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
183
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
184 #endif /* (not) NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
185
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
186 /* Very cheesy ways of figuring out how much memory is being used for
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
187 data. #### Need better (system-dependent) ways. */
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
188 void *minimum_address_seen;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
189 void *maximum_address_seen;
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
190
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
192 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
193 /* Low-level allocation */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
194 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
195
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
196 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
197 recompute_funcall_allocation_flag (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
198 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
199 funcall_allocation_flag =
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
200 need_to_garbage_collect ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
201 need_to_check_c_alloca ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
202 need_to_signal_post_gc;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
203 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
204
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 /* Maximum amount of C stack to save when a GC happens. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 #ifndef MAX_SAVE_STACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 #define MAX_SAVE_STACK 0 /* 16000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 /* Non-zero means ignore malloc warnings. Set during initialization. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 int ignore_malloc_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
215 #ifndef NEW_GC
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
216 void *breathing_space;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 release_breathing_space (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 if (breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 void *tmp = breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 breathing_space = 0;
4976
16112448d484 Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents: 4969
diff changeset
225 xfree (tmp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 }
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
228
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
229 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
230 /* If we released our reserve (due to running out of memory),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
231 and we have a fair amount free once again,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
232 try to set aside another reserve in case we run out once more.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
233
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
234 This is called when a relocatable block is freed in ralloc.c. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
235 void refill_memory_reserve (void);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
236 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
237 refill_memory_reserve (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
238 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
239 if (breathing_space == 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
240 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
241 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
242 #endif /* !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
243
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
244 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
246 static void
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
247 set_alloc_mins_and_maxes (void *val, Bytecount size)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
248 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
249 if (!val)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
250 return;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
251 if ((char *) val + size > (char *) maximum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
252 maximum_address_seen = (char *) val + size;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
253 if (!minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
254 minimum_address_seen =
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
255 #if SIZEOF_VOID_P == 8
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
256 (void *) 0xFFFFFFFFFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
257 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
258 (void *) 0xFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
259 #endif
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
260 if ((char *) val < (char *) minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
261 minimum_address_seen = (char *) val;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
262 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
263
1315
70921960b980 [xemacs-hg @ 2003-02-20 08:19:28 by ben]
ben
parents: 1292
diff changeset
264 #ifdef ERROR_CHECK_MALLOC
3176
1c2a4e4e81d9 [xemacs-hg @ 2005-12-25 11:21:45 by aidan]
aidan
parents: 3170
diff changeset
265 static int in_malloc;
1333
1b0339b048ce [xemacs-hg @ 2003-03-02 09:38:37 by ben]
ben
parents: 1318
diff changeset
266 extern int regex_malloc_disallowed;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
267
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
268 #define MALLOC_BEGIN() \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
269 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
270 { \
3176
1c2a4e4e81d9 [xemacs-hg @ 2005-12-25 11:21:45 by aidan]
aidan
parents: 3170
diff changeset
271 assert (!in_malloc); \
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
272 assert (!regex_malloc_disallowed); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
273 in_malloc = 1; \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
274 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
275 while (0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
276
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
277 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
278 #define FREE_OR_REALLOC_BEGIN(block) \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
279 do \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
280 { \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
281 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
282 error until much later on for many system mallocs, such as \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
283 the one that comes with Solaris 2.3. FMH!! */ \
4938
299dce99bdad (for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents: 4934
diff changeset
284 assert (block != (void *) DEADBEEF_CONSTANT); \
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
285 MALLOC_BEGIN (); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
286 } \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
287 while (0)
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
288 #else /* not NEW_GC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
289 #define FREE_OR_REALLOC_BEGIN(block) \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
290 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
291 { \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
292 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
293 error until much later on for many system mallocs, such as \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
294 the one that comes with Solaris 2.3. FMH!! */ \
4938
299dce99bdad (for main branch) when freeing check against DEADBEEF_CONSTANT since that's what we use elsewhere
Ben Wing <ben@xemacs.org>
parents: 4934
diff changeset
295 assert (block != (void *) DEADBEEF_CONSTANT); \
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
296 /* You cannot free something within dumped space, because there is \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
297 no longer any sort of malloc structure associated with the block. \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
298 If you are tripping this, you may need to conditionalize on \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
299 DUMPEDP. */ \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
300 assert (!DUMPEDP (block)); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
301 MALLOC_BEGIN (); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
302 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
303 while (0)
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
304 #endif /* not NEW_GC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
305
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
306 #define MALLOC_END() \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
307 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
308 { \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
309 in_malloc = 0; \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
310 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
311 while (0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
312
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
313 #else /* ERROR_CHECK_MALLOC */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
314
2658
a48989ca6db3 [xemacs-hg @ 2005-03-13 09:20:58 by crestani]
crestani
parents: 2650
diff changeset
315 #define MALLOC_BEGIN()
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
316 #define FREE_OR_REALLOC_BEGIN(block)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
317 #define MALLOC_END()
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
318
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
319 #endif /* ERROR_CHECK_MALLOC */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
320
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
321 static void
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
322 malloc_after (void *val, Bytecount size)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
323 {
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
324 if (!val && size != 0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
325 memory_full ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
326 set_alloc_mins_and_maxes (val, size);
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
327 }
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
328
3305
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
329 /* malloc calls this if it finds we are near exhausting storage */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
330 void
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
331 malloc_warning (const char *str)
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
332 {
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
333 if (ignore_malloc_warnings)
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
334 return;
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
335
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
336 /* Remove the malloc lock here, because warn_when_safe may allocate
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
337 again. It is safe to remove the malloc lock here, because malloc
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
338 is already finished (malloc_warning is called via
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
339 after_morecore_hook -> check_memory_limits -> save_warn_fun ->
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
340 malloc_warning). */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
341 MALLOC_END ();
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
342
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
343 warn_when_safe
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
344 (Qmemory, Qemergency,
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
345 "%s\n"
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
346 "Killing some buffers may delay running out of memory.\n"
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
347 "However, certainly by the time you receive the 95%% warning,\n"
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
348 "you should clean up, kill this Emacs, and start a new one.",
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
349 str);
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
350 }
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
351
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
352 /* Called if malloc returns zero */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
353 DOESNT_RETURN
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
354 memory_full (void)
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
355 {
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
356 /* Force a GC next time eval is called.
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
357 It's better to loop garbage-collecting (we might reclaim enough
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
358 to win) than to loop beeping and barfing "Memory exhausted"
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
359 */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
360 consing_since_gc = gc_cons_threshold + 1;
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
361 recompute_need_to_garbage_collect ();
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
362 #ifdef NEW_GC
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
363 /* Put mc-alloc into memory shortage mode. This may keep XEmacs
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
364 alive until the garbage collector can free enough memory to get
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
365 us out of the memory exhaustion. If already in memory shortage
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
366 mode, we are in a loop and hopelessly lost. */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
367 if (memory_shortage)
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
368 {
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
369 fprintf (stderr, "Memory full, cannot recover.\n");
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
370 ABORT ();
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
371 }
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
372 fprintf (stderr,
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
373 "Memory full, try to recover.\n"
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
374 "You should clean up, kill this Emacs, and start a new one.\n");
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
375 memory_shortage++;
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
376 #else /* not NEW_GC */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
377 release_breathing_space ();
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
378 #endif /* not NEW_GC */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
379
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
380 /* Flush some histories which might conceivably contain garbalogical
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
381 inhibitors. */
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
382 if (!NILP (Fboundp (Qvalues)))
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
383 Fset (Qvalues, Qnil);
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
384 Vcommand_history = Qnil;
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
385
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
386 out_of_memory ("Memory exhausted", Qunbound);
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
387 }
1043bbfa24cf [xemacs-hg @ 2006-03-26 15:24:25 by crestani]
crestani
parents: 3304
diff changeset
388
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
389 /* like malloc, calloc, realloc, free but:
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
390
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
391 -- check for no memory left
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
392 -- set internal mins and maxes
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
393 -- with error-checking on, check for reentrancy, invalid freeing, etc.
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
394 */
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
395
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 #undef xmalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
398 xmalloc (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 {
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
400 void *val;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
401 MALLOC_BEGIN ();
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
402 val = malloc (size);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
403 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
404 malloc_after (val, size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 #undef xcalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
410 xcalloc (Elemcount nelem, Bytecount elsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 {
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
412 void *val;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
413 MALLOC_BEGIN ();
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
414 val= calloc (nelem, elsize);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
415 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
416 malloc_after (val, nelem * elsize);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
421 xmalloc_and_zero (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 return xcalloc (size, sizeof (char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 #undef xrealloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
428 xrealloc (void *block, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
430 FREE_OR_REALLOC_BEGIN (block);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
431 block = realloc (block, size);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
432 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
433 malloc_after (block, size);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
434 return block;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 xfree_1 (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 assert (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 #endif /* ERROR_CHECK_MALLOC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
443 FREE_OR_REALLOC_BEGIN (block);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 free (block);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
445 MALLOC_END ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
448 void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
449 deadbeef_memory (void *ptr, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
451 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
452 Bytecount beefs = size >> 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 while (beefs--)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
456 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
461 xstrdup (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 void *val = xmalloc (len);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
465
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 return (char *) memcpy (val, str, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
472 strdup (const char *s)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 #endif /* NEED_STRDUP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
479 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
480 /* Lisp object allocation */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
481 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
482
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
483 /* Determine now whether we need to garbage collect or not, to make
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
484 Ffuncall() faster */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
485 #define INCREMENT_CONS_COUNTER_1(size) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
486 do \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
487 { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
488 consing_since_gc += (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
489 total_consing += (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
490 if (profiling_active) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
491 profile_record_consing (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
492 recompute_need_to_garbage_collect (); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
493 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
494
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
495 #define debug_allocation_backtrace() \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
496 do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
497 if (debug_allocation_backtrace_length > 0) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
498 debug_short_backtrace (debug_allocation_backtrace_length); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
499 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
500
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
501 #ifdef DEBUG_XEMACS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
502 #define INCREMENT_CONS_COUNTER(foosize, type) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
503 do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
504 if (debug_allocation) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
505 { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
506 stderr_out ("allocating %s (size %ld)\n", type, \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
507 (long) foosize); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
508 debug_allocation_backtrace (); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
509 } \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
510 INCREMENT_CONS_COUNTER_1 (foosize); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
511 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
512 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
513 do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
514 if (debug_allocation > 1) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
515 { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
516 stderr_out ("allocating noseeum %s (size %ld)\n", type, \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
517 (long) foosize); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
518 debug_allocation_backtrace (); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
519 } \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
520 INCREMENT_CONS_COUNTER_1 (foosize); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
521 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
522 #else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
523 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
524 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
525 INCREMENT_CONS_COUNTER_1 (size)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
526 #endif
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
527
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
528 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
529 /* [[ The call to recompute_need_to_garbage_collect is moved to
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
530 free_normal_lisp_object, since DECREMENT_CONS_COUNTER is extensively called
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
531 during sweep and recomputing need_to_garbage_collect all the time
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
532 is not needed. ]] -- not accurate! */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
533 #define DECREMENT_CONS_COUNTER(size) do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
534 consing_since_gc -= (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
535 total_consing -= (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
536 if (profiling_active) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
537 profile_record_unconsing (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
538 if (consing_since_gc < 0) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
539 consing_since_gc = 0; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
540 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
541 #else /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
542 #define DECREMENT_CONS_COUNTER(size) do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
543 consing_since_gc -= (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
544 total_consing -= (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
545 if (profiling_active) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
546 profile_record_unconsing (size); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
547 if (consing_since_gc < 0) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
548 consing_since_gc = 0; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
549 recompute_need_to_garbage_collect (); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
550 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
551 #endif /*not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
552
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
553 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
555 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
557 void *val = xmalloc (size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
558 /* We don't increment the cons counter anymore. Calling functions do
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
559 that now because we have two different kinds of cons counters -- one
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
560 for normal objects, and one for no-see-um conses (and possibly others
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
561 similar) where the conses are used totally internally, never escape,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
562 and are created and then freed and shouldn't logically increment the
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
563 cons counting. #### (Or perhaps, we should decrement it when an object
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
564 get freed?) */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
565
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
566 /* But we do now (as of 3-27-02) go and zero out the memory. This is a
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
567 good thing, as it will guarantee we won't get any intermittent bugs
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
568 coming from an uninitiated field. The speed loss is unnoticeable,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
569 esp. as the objects are not large -- large stuff like buffer text and
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
570 redisplay structures are allocated separately. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
571 memset (val, 0, size);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
572
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
573 if (need_to_check_c_alloca)
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
574 xemacs_c_alloca (0);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
575
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
576 return val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
578 #endif /* not NEW_GC */
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
579
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
580 #define assert_proper_sizing(size) \
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
581 type_checking_assert \
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
582 (implementation->static_size == 0 ? \
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
583 implementation->size_in_bytes_method != NULL : \
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
584 implementation->size_in_bytes_method == NULL && \
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
585 implementation->static_size == size)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
586
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
587 #ifndef NEW_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
588 /* lcrecords are chained together through their "next" field.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
589 After doing the mark phase, GC will walk this linked list
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
590 and free any lcrecord which hasn't been marked. */
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
591 static struct old_lcrecord_header *all_lcrecords;
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
592 #endif /* not NEW_GC */
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
593
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
594 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
595 /* The basic lrecord allocation functions. See lrecord.h for details. */
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
596 static Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
597 alloc_sized_lrecord_1 (Bytecount size,
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
598 const struct lrecord_implementation *implementation,
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
599 int noseeum)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
600 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
601 struct lrecord_header *lheader;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
602
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
603 assert_proper_sizing (size);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
604
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
605 lheader = (struct lrecord_header *) mc_alloc (size);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
606 gc_checking_assert (LRECORD_FREE_P (lheader));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
607 set_lheader_implementation (lheader, implementation);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
608 #ifdef ALLOC_TYPE_STATS
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
609 inc_lrecord_stats (size, lheader);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
610 #endif /* ALLOC_TYPE_STATS */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
611 if (implementation->finalizer)
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
612 add_finalizable_obj (wrap_pointer_1 (lheader));
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
613 if (noseeum)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
614 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
615 else
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
616 INCREMENT_CONS_COUNTER (size, implementation->name);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
617 return wrap_pointer_1 (lheader);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
618 }
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
619
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
620 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
621 alloc_sized_lrecord (Bytecount size,
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
622 const struct lrecord_implementation *implementation)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
623 {
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
624 return alloc_sized_lrecord_1 (size, implementation, 0);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
625 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
626
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
627 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
628 noseeum_alloc_sized_lrecord (Bytecount size,
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
629 const struct lrecord_implementation *
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
630 implementation)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
631 {
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
632 return alloc_sized_lrecord_1 (size, implementation, 1);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
633 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
634
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
635 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
636 alloc_lrecord (const struct lrecord_implementation *implementation)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
637 {
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
638 type_checking_assert (implementation->static_size > 0);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
639 return alloc_sized_lrecord (implementation->static_size, implementation);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
640 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
641
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
642 Lisp_Object
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
643 noseeum_alloc_lrecord (const struct lrecord_implementation *implementation)
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
644 {
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
645 type_checking_assert (implementation->static_size > 0);
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
646 return noseeum_alloc_sized_lrecord (implementation->static_size, implementation);
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
647 }
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
648
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
649 Lisp_Object
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
650 alloc_sized_lrecord_array (Bytecount size, int elemcount,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
651 const struct lrecord_implementation *implementation)
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
652 {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
653 struct lrecord_header *lheader;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
654 Rawbyte *start, *stop;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
655
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
656 assert_proper_sizing (size);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
657
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
658 lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
659 gc_checking_assert (LRECORD_FREE_P (lheader));
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
660
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
661 for (start = (Rawbyte *) lheader,
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
662 /* #### FIXME: why is this -1 present? */
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
663 stop = ((Rawbyte *) lheader) + (size * elemcount -1);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
664 start < stop; start += size)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
665 {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
666 struct lrecord_header *lh = (struct lrecord_header *) start;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
667 set_lheader_implementation (lh, implementation);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
668 #ifdef ALLOC_TYPE_STATS
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
669 inc_lrecord_stats (size, lh);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
670 #endif /* not ALLOC_TYPE_STATS */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
671 if (implementation->finalizer)
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
672 add_finalizable_obj (wrap_pointer_1 (lh));
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
673 }
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
674
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
675 INCREMENT_CONS_COUNTER (size * elemcount, implementation->name);
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
676 return wrap_pointer_1 (lheader);
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
677 }
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
678
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
679 Lisp_Object
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
680 alloc_lrecord_array (int elemcount,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
681 const struct lrecord_implementation *implementation)
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
682 {
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
683 type_checking_assert (implementation->static_size > 0);
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
684 return alloc_sized_lrecord_array (implementation->static_size, elemcount,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
685 implementation);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
686 }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
687
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
688 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
690 /* The most basic of the lcrecord allocation functions. Not usually called
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
691 directly. Allocates an lrecord not managed by any lcrecord-list, of a
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
692 specified size. See lrecord.h. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
693
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
694 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
695 old_alloc_sized_lcrecord (Bytecount size,
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
696 const struct lrecord_implementation *implementation)
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
697 {
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
698 struct old_lcrecord_header *lcheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
700 assert_proper_sizing (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
701 type_checking_assert
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
702 (!implementation->frob_block_p
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
703 &&
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
704 !(implementation->hash == NULL && implementation->equal != NULL));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
706 lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
707 set_lheader_implementation (&lcheader->lheader, implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 lcheader->next = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 all_lcrecords = lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 INCREMENT_CONS_COUNTER (size, implementation->name);
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
711 return wrap_pointer_1 (lcheader);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
712 }
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
713
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
714 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
715 old_alloc_lcrecord (const struct lrecord_implementation *implementation)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
716 {
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
717 type_checking_assert (implementation->static_size > 0);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
718 return old_alloc_sized_lcrecord (implementation->static_size,
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
719 implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 #if 0 /* Presently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 /* Very, very poor man's EGC?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 * This may be slow and thrash pages all over the place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 * Only call it if you really feel you must (and if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 * lrecord was fairly recently allocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 * Otherwise, just let the GC do its job -- that's what it's there for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
730 very_old_free_lcrecord (struct old_lcrecord_header *lcrecord)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 if (all_lcrecords == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 all_lcrecords = lcrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
738 struct old_lcrecord_header *header = all_lcrecords;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
741 struct old_lcrecord_header *next = header->next;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 if (next == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 header->next = lrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 else if (next == 0)
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
748 ABORT ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 if (lrecord->implementation->finalizer)
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
754 lrecord->implementation->finalizer (wrap_pointer_1 (lrecord));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 xfree (lrecord);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 #endif /* Unused */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
759 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
761 /* Bitwise copy all parts of a Lisp object other than the header */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
762
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
763 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
764 copy_lisp_object (Lisp_Object dst, Lisp_Object src)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
765 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
766 const struct lrecord_implementation *imp =
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
767 XRECORD_LHEADER_IMPLEMENTATION (src);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
768 Bytecount size = lisp_object_size (src);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
769
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
770 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
771 assert (size == lisp_object_size (dst));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
772
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
773 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
774 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
775 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
776 size - sizeof (struct lrecord_header));
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
777 #else /* not NEW_GC */
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
778 if (imp->frob_block_p)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
779 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
780 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
781 size - sizeof (struct lrecord_header));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
782 else
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
783 memcpy ((char *) XRECORD_LHEADER (dst) +
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
784 sizeof (struct old_lcrecord_header),
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
785 (char *) XRECORD_LHEADER (src) +
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
786 sizeof (struct old_lcrecord_header),
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
787 size - sizeof (struct old_lcrecord_header));
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
788 #endif /* not NEW_GC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
789 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
790
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
791 /* Zero out all parts of a Lisp object other than the header, for a
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
792 variable-sized object. The size needs to be given explicitly because
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
793 at the time this is called, the contents of the object may not be
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
794 defined, or may not be set up in such a way that we can reliably
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
795 retrieve the size, since it may depend on settings inside of the object. */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
796
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
797 void
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
798 zero_sized_lisp_object (Lisp_Object obj, Bytecount size)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
799 {
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
800 #ifndef NEW_GC
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
801 const struct lrecord_implementation *imp =
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
802 XRECORD_LHEADER_IMPLEMENTATION (obj);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
803 #endif /* not NEW_GC */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
804
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
805 #ifdef NEW_GC
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
806 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0,
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
807 size - sizeof (struct lrecord_header));
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
808 #else /* not NEW_GC */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
809 if (imp->frob_block_p)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
810 memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0,
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
811 size - sizeof (struct lrecord_header));
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
812 else
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
813 memset ((char *) XRECORD_LHEADER (obj) +
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
814 sizeof (struct old_lcrecord_header), 0,
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
815 size - sizeof (struct old_lcrecord_header));
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
816 #endif /* not NEW_GC */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
817 }
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
818
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
819 /* Zero out all parts of a Lisp object other than the header, for an object
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
820 that isn't variable-size. Objects that are variable-size need to use
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
821 zero_sized_lisp_object().
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
822 */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
823
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
824 void
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
825 zero_nonsized_lisp_object (Lisp_Object obj)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
826 {
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
827 const struct lrecord_implementation *imp =
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
828 XRECORD_LHEADER_IMPLEMENTATION (obj);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
829 assert (!imp->size_in_bytes_method);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
830
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
831 zero_sized_lisp_object (obj, lisp_object_size (obj));
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
832 }
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
833
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
834 void
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
835 free_normal_lisp_object (Lisp_Object obj)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
836 {
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
837 #ifndef NEW_GC
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
838 const struct lrecord_implementation *imp =
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
839 XRECORD_LHEADER_IMPLEMENTATION (obj);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
840 #endif /* not NEW_GC */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
841
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
842 #ifdef NEW_GC
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
843 /* Manual frees are not allowed with asynchronous finalization */
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
844 return;
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
845 #else
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
846 assert (!imp->frob_block_p);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
847 assert (!imp->size_in_bytes_method);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
848 old_free_lcrecord (obj);
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
849 #endif
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
850 }
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
851
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
852 #ifndef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
853 int
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
854 c_readonly (Lisp_Object obj)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
855 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
856 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
857 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
858 #endif /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
859
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
860 int
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
861 lisp_readonly (Lisp_Object obj)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
862 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
863 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
864 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
865
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
866 /* #### Should be made into an object method */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
867
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
868 int
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
869 object_dead_p (Lisp_Object obj)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
870 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
871 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
872 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
873 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
874 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
875 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
876 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
877 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
878 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
879
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 /************************************************************************/
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
882 /* Debugger support */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 /* Give gdb/dbx enough information to decode Lisp Objects. We make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 sure certain symbols are always defined, so gdb doesn't complain
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
886 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
887 to see how this is used. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
889 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
890 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 #ifdef USE_UNION_TYPE
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
893 unsigned char dbg_USE_UNION_TYPE = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 #else
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
895 unsigned char dbg_USE_UNION_TYPE = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
898 unsigned char dbg_valbits = VALBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
899 unsigned char dbg_gctypebits = GCTYPEBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
900
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
901 /* On some systems, the above definitions will be optimized away by
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
902 the compiler or linker unless they are referenced in some function. */
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
903 long dbg_inhibit_dbg_symbol_deletion (void);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
904 long
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
905 dbg_inhibit_dbg_symbol_deletion (void)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
906 {
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
907 return
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
908 (dbg_valmask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
909 dbg_typemask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
910 dbg_USE_UNION_TYPE +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
911 dbg_valbits +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
912 dbg_gctypebits);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
913 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 /* Macros turned into functions for ease of debugging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 Debuggers don't know about macros! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 return EQ (obj1, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
925 #ifdef NEW_GC
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
926 #define DECLARE_FIXED_TYPE_ALLOC(type, structture) struct __foo__
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
927 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 /************************************************************************/
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
929 /* Fixed-size type macros */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 /* For fixed-size types that are commonly used, we malloc() large blocks
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 of memory at a time and subdivide them into chunks of the correct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 size for an object of that type. This is more efficient than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 malloc()ing each object separately because we save on malloc() time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 and overhead due to the fewer number of malloc()ed blocks, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 also because we don't need any extra pointers within each object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 to keep them threaded together for GC purposes. For less common
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 (and frequently large-size) types, we use lcrecords, which are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 malloc()ed individually and chained together through a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 in the lcrecord header. lcrecords do not need to be fixed-size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 (i.e. two objects of the same type need not have the same size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 however, the size of a particular object cannot vary dynamically).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 It is also much easier to create a new lcrecord type because no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 additional code needs to be added to alloc.c. Finally, lcrecords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 may be more efficient when there are only a small number of them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 The types that are stored in these large blocks (or "frob blocks")
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
949 are cons, all number types except fixnum, compiled-function, symbol,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
950 marker, extent, event, and string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 Note that strings are special in that they are actually stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 two parts: a structure containing information about the string, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 the actual data associated with the string. The former structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 (a struct Lisp_String) is a fixed-size structure and is managed the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 same way as all the other such types. This structure contains a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 pointer to the actual string data, which is stored in structures of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 type struct string_chars_block. Each string_chars_block consists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 of a pointer to a struct Lisp_String, followed by the data for that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
960 string, followed by another pointer to a Lisp_String, followed by
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
961 the data for that string, etc. At GC time, the data in these
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
962 blocks is compacted by searching sequentially through all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 blocks and compressing out any holes created by unmarked strings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 Strings that are more than a certain size (bigger than the size of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 a string_chars_block, although something like half as big might
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 make more sense) are malloc()ed separately and not stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 string_chars_blocks. Furthermore, no one string stretches across
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 two string_chars_blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
970 Vectors are each malloc()ed separately as lcrecords.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 In the following discussion, we use conses, but it applies equally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 well to the other fixed-size types.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 We store cons cells inside of cons_blocks, allocating a new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 cons_block with malloc() whenever necessary. Cons cells reclaimed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 by GC are put on a free list to be reallocated before allocating
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 any new cons cells from the latest cons_block. Each cons_block is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 the versions in malloc.c and gmalloc.c) really allocates in units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 of powers of two and uses 4 bytes for its own overhead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 What GC actually does is to search through all the cons_blocks,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 from the most recently allocated to the oldest, and put all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 cons cells that are not marked (whether or not they're already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 free) on a cons_free_list. The cons_free_list is a stack, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 so the cons cells in the oldest-allocated cons_block end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 at the head of the stack and are the first to be reallocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 If any cons_block is entirely free, it is freed with free()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 and its cons cells removed from the cons_free_list. Because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 the cons_free_list ends up basically in memory order, we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 a high locality of reference (assuming a reasonable turnover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 of allocating and freeing) and have a reasonable probability
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 of entirely freeing up cons_blocks that have been more recently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 allocated. This stage is called the "sweep stage" of GC, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 is executed after the "mark stage", which involves starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 from all places that are known to point to in-use Lisp objects
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 (e.g. the obarray, where are all symbols are stored; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 current catches and condition-cases; the backtrace list of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 currently executing functions; the gcpro list; etc.) and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 recursively marking all objects that are accessible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1003 At the beginning of the sweep stage, the conses in the cons blocks
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1004 are in one of three states: in use and marked, in use but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1005 marked, and not in use (already freed). Any conses that are marked
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1006 have been marked in the mark stage just executed, because as part
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1007 of the sweep stage we unmark any marked objects. The way we tell
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1008 whether or not a cons cell is in use is through the LRECORD_FREE_P
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1009 macro. This uses a special lrecord type `lrecord_type_free',
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1010 which is never associated with any valid object.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1011
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1012 Conses on the free_cons_list are threaded through a pointer stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1013 in the conses themselves. Because the cons is still in a
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1014 cons_block and needs to remain marked as not in use for the next
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1015 time that GC happens, we need room to store both the "free"
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1016 indicator and the chaining pointer. So this pointer is stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1017 after the lrecord header (actually where C places a pointer after
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1018 the lrecord header; they are not necessarily contiguous). This
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1019 implies that all fixed-size types must be big enough to contain at
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1020 least one pointer. This is true for all current fixed-size types,
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1021 with the possible exception of Lisp_Floats, for which we define the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1022 meat of the struct using a union of a pointer and a double to
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1023 ensure adequate space for the free list chain pointer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 Some types of objects need additional "finalization" done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 when an object is converted from in use to not in use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 this is the purpose of the ADDITIONAL_FREE_type macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 For example, markers need to be removed from the chain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 of markers that is kept in each buffer. This is because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 markers in a buffer automatically disappear if the marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 is no longer referenced anywhere (the same does not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 apply to extents, however).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 WARNING: Things are in an extremely bizarre state when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 the ADDITIONAL_FREE_type macros are called, so beware!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1037 When ERROR_CHECK_GC is defined, we do things differently so as to
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1038 maximize our chances of catching places where there is insufficient
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1039 GCPROing. The thing we want to avoid is having an object that
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1040 we're using but didn't GCPRO get freed by GC and then reallocated
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1041 while we're in the process of using it -- this will result in
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1042 something seemingly unrelated getting trashed, and is extremely
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1043 difficult to track down. If the object gets freed but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1044 reallocated, we can usually catch this because we set most of the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1045 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1046 to the invalid type `lrecord_type_free', however, and a pointer
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1047 used to chain freed objects together is stored after the lrecord
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1048 header; we play some tricks with this pointer to make it more
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 bogus, so crashes are more likely to occur right away.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 We want freed objects to stay free as long as possible,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 so instead of doing what we do above, we maintain the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 free objects in a first-in first-out queue. We also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 don't recompute the free list each GC, unlike above;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 this ensures that the queue ordering is preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 [This means that we are likely to have worse locality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 of reference, and that we can never free a frob block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 once it's allocated. (Even if we know that all cells
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 in it are free, there's no easy way to remove all those
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 cells from the free list because the objects on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 free list are unlikely to be in memory order.)]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 Furthermore, we never take objects off the free list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 unless there's a large number (usually 1000, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 varies depending on type) of them already on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 This way, we ensure that an object that gets freed will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 remain free for the next 1000 (or whatever) times that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1067 an object of that type is allocated. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 #ifdef ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 # define TYPE_ALLOC_SIZE(type, structtype) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 # define TYPE_ALLOC_SIZE(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 / sizeof (structtype))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 struct type##_block \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 struct type##_block *prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 }; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 static struct type##_block *current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 static int current_##type##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1088 static Lisp_Free *type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1089 static Lisp_Free *type##_free_list_tail; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 static void \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 init_##type##_alloc (void) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 current_##type##_block = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 current_##type##_block_index = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 countof (current_##type##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 type##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 type##_free_list_tail = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 static int gc_count_num_##type##_in_use; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 static int gc_count_num_##type##_freelist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 if (current_##type##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 == countof (current_##type##_block->block)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 struct type##_block *AFTFB_new = (struct type##_block *) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 allocate_lisp_storage (sizeof (struct type##_block)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 AFTFB_new->prev = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 current_##type##_block = AFTFB_new; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 current_##type##_block_index = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 (result) = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 &(current_##type##_block->block[current_##type##_block_index++]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 /* Allocate an instance of a type that is stored in blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 structure type. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 /* Note: if you get crashes in this function, suspect incorrect calls
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 to free_cons() and friends. This happened once because the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 cell was not GC-protected and was getting collected before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 free_cons() was called. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1129 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1130 if (gc_count_num_##type##_freelist > \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1131 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1132 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1133 result = (structtype *) type##_free_list; \
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1134 assert (LRECORD_FREE_P (result)); \
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1135 /* Before actually using the chain pointer, we complement \
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1136 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1137 type##_free_list = (Lisp_Free *) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1138 (~ (EMACS_UINT) (type##_free_list->chain)); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1139 gc_count_num_##type##_freelist--; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1140 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1141 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1142 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1143 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1148 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 if (type##_free_list) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 { \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1151 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1152 type##_free_list = type##_free_list->chain; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1156 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1161
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1176 /* Lisp_Free is the type to represent a free list member inside a frob
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1177 block of any lisp object type. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1178 typedef struct Lisp_Free
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1179 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1180 struct lrecord_header lheader;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1181 struct Lisp_Free *chain;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1182 } Lisp_Free;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1183
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1184 #define LRECORD_FREE_P(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1185 (((struct lrecord_header *) ptr)->type == lrecord_type_free)
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1186
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1187 #define MARK_LRECORD_AS_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1188 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1189
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1190 #ifdef ERROR_CHECK_GC
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1191 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1192 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 #else
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1194 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1199 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1200 if (type##_free_list_tail) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1201 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1202 /* When we store the chain pointer, we complement all \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1203 its bits; this should significantly increase its \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1204 bogosity in case someone tries to use the value, and \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1205 should make us crash faster if someone overwrites the \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1206 pointer because when it gets un-complemented in \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1207 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1208 extremely bogus. */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1209 type##_free_list_tail->chain = \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1210 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1211 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1212 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1213 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1214 type##_free_list_tail = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1215 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1219 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1220 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1221 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1222 } while (0) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 structtype *FFT_ptr = (ptr); \
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1230 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
1231 gc_checking_assert (!DUMPEDP (FFT_ptr)); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 ADDITIONAL_FREE_##type (FFT_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1235 MARK_LRECORD_AS_FREE (FFT_ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 } while (0)
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1237 #endif /* NEW_GC */
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1238
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1239 #ifdef NEW_GC
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1240 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1241 free_normal_lisp_object (lo)
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1242 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 /* Like FREE_FIXED_TYPE() but used when we are explicitly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 freeing a structure through free_cons(), free_marker(), etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 rather than through the normal process of sweeping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 We attempt to undo the changes made to the allocation counters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 as a result of this structure being allocated. This is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 completely necessary but helps keep things saner: e.g. this way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 repeatedly allocating and freeing a cons will not result in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 the consing-since-gc counter advancing, which would cause a GC
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1251 and somewhat defeat the purpose of explicitly freeing.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1252
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1253 We also disable this mechanism entirely when ALLOC_NO_POOLS is
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1254 set, which is used for Purify and the like. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1255
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1256 #ifndef ALLOC_NO_POOLS
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1257 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1258 do { FREE_FIXED_TYPE (type, structtype, ptr); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1259 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1260 gc_count_num_##type##_freelist++; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 } while (0)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1262 #else
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1263 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1264 #endif
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
1265 #endif /* (not) NEW_GC */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
1266
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
1267 #ifdef NEW_GC
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1268 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1269 do { \
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1270 (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1271 } while (0)
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1272 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1273 lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1274 do { \
5120
d1247f3cc363 latest work on lisp-object workspace;
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
1275 (var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr)); \
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1276 } while (0)
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
1277 #else /* not NEW_GC */
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1278 #define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1279 do \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1280 { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1281 ALLOCATE_FIXED_TYPE (type, lisp_type, var); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1282 set_lheader_implementation (&(var)->lheader, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1283 } while (0)
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1284 #define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1285 lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1286 do \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1287 { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1288 NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1289 set_lheader_implementation (&(var)->lheader, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1290 } while (0)
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
1291 #endif /* not NEW_GC */
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1292
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 /* Cons allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1299 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 /* conses are used and freed so often that we set this really high */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 mark_cons (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 if (NILP (XCDR (obj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 return XCAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 mark_object (XCAR (obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 return XCDR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 static int
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
1315 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth, int foldcase)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1317 depth++;
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
1318 while (internal_equal_0 (XCAR (ob1), XCAR (ob2), depth, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 ob1 = XCDR (ob1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 ob2 = XCDR (ob2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 if (! CONSP (ob1) || ! CONSP (ob2))
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
1323 return internal_equal_0 (ob1, ob2, depth, foldcase);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1328 static const struct memory_description cons_description[] = {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1329 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) },
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1330 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1334 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("cons", cons,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1335 mark_cons, print_cons, 0, cons_equal,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1336 /*
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1337 * No `hash' method needed.
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1338 * internal_hash knows how to
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1339 * handle conses.
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1340 */
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1341 0, cons_description, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 DEFUN ("cons", Fcons, 2, 2, 0, /*
3355
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1344 Create a new cons cell, give it CAR and CDR as components, and return it.
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1345
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1346 A cons cell is a Lisp object (an area in memory) made up of two pointers
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1347 called the CAR and the CDR. Each of these pointers can point to any other
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1348 Lisp object. The common Lisp data type, the list, is a specially-structured
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1349 series of cons cells.
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1350
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1351 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1352 `setcar' and `setcdr' respectively. For historical reasons, the aliases
721daee0fcd8 [xemacs-hg @ 2006-04-23 20:12:25 by aidan]
aidan
parents: 3305
diff changeset
1353 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 (car, cdr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1359 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1360
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1361 ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1362 val = wrap_cons (c);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1363 XSETCAR (val, car);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1364 XSETCDR (val, cdr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 /* This is identical to Fcons() but it used for conses that we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 going to free later, and is useful when trying to track down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 "real" consing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1375 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1376
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1377 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1378 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 XCAR (val) = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 XCDR (val) = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 DEFUN ("list", Flist, 0, MANY, 0, /*
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1385 Return a newly created list with specified ARGS as elements.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 Any number of arguments, even zero arguments, are allowed.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1387
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1388 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 Lisp_Object val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 Lisp_Object *argp = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 while (argp > args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 val = Fcons (*--argp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 list1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 return Fcons (obj0, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408 list2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 return Fcons (obj0, Fcons (obj1, Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 return Fcons (obj0, Fcons (obj1, obj2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 return Fcons (Fcons (key, value), alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1457 /* Return a list of arbitrary length, terminated by Qunbound. */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1458
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1459 Lisp_Object
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1460 listu (Lisp_Object first, ...)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1461 {
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1462 Lisp_Object obj = Qnil;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1463 Lisp_Object val;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1464 va_list va;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1465
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1466 va_start (va, first);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1467 val = first;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1468 while (!UNBOUNDP (val))
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1469 {
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1470 obj = Fcons (val, obj);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1471 val = va_arg (va, Lisp_Object);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1472 }
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1473 va_end (va);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1474 return Fnreverse (obj);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1475 }
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1476
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1477 /* Return a list of arbitrary length, with length specified and remaining
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1478 args making up the list. */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1479
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1480 Lisp_Object
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1481 listn (int num_args, ...)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1482 {
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1483 int i;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1484 Lisp_Object obj = Qnil;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1485 va_list va;
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1486
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1487 va_start (va, num_args);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1488 for (i = 0; i < num_args; i++)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1489 obj = Fcons (va_arg (va, Lisp_Object), obj);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1490 va_end (va);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1491 return Fnreverse (obj);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1492 }
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1493
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1494 /* Return a list of arbitrary length, with length specified and an array
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1495 of elements. */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
1496
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1498 Return a new list of length LENGTH, with each element being OBJECT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1500 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 CHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 Lisp_Object val = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1506 EMACS_INT size = XINT (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 while (size--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1509 val = Fcons (object, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 /* Float allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1519 /*** With enhanced number support, these are short floats */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1520
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1521 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 make_float (double float_value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1527 Lisp_Float *f;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1528
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1529 ALLOC_FROB_BLOCK_LISP_OBJECT (float, Lisp_Float, f, &lrecord_float);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1530
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1531 /* Avoid dump-time `uninitialized memory read' purify warnings. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1532 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1533 zero_nonsized_lisp_object (wrap_float (f));
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1534
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 float_data (f) = float_value;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1536 return wrap_float (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 /************************************************************************/
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1541 /* Enhanced number allocation */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1542 /************************************************************************/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1543
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1544 /*** Bignum ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1545 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1546 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1547 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1548
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1549 /* WARNING: This function returns a bignum even if its argument fits into a
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1550 fixnum. See Fcanonicalize_number(). */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1551 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1552 make_bignum (long bignum_value)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1553 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1554 Lisp_Bignum *b;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1555
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1556 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1557 bignum_init (bignum_data (b));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1558 bignum_set_long (bignum_data (b), bignum_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1559 return wrap_bignum (b);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1560 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1561
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1562 /* WARNING: This function returns a bignum even if its argument fits into a
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1563 fixnum. See Fcanonicalize_number(). */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1564 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1565 make_bignum_bg (bignum bg)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1566 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1567 Lisp_Bignum *b;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1568
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1569 ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1570 bignum_init (bignum_data (b));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1571 bignum_set (bignum_data (b), bg);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1572 return wrap_bignum (b);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1573 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1574 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1575
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1576 /*** Ratio ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1577 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1578 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1579 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1580
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1581 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1582 make_ratio (long numerator, unsigned long denominator)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1583 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1584 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1585
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1586 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1587 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1588 ratio_set_long_ulong (ratio_data (r), numerator, denominator);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1589 ratio_canonicalize (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1590 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1591 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1592
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1593 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1594 make_ratio_bg (bignum numerator, bignum denominator)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1595 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1596 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1597
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1598 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1599 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1600 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1601 ratio_canonicalize (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1602 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1603 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1604
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1605 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1606 make_ratio_rt (ratio rat)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1607 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1608 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1609
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1610 ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1611 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1612 ratio_set (ratio_data (r), rat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1613 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1614 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1615 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1616
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1617 /*** Bigfloat ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1618 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1619 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1620 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1621
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1622 /* This function creates a bigfloat with the default precision if the
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1623 PRECISION argument is zero. */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1624 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1625 make_bigfloat (double float_value, unsigned long precision)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1626 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1627 Lisp_Bigfloat *f;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1628
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1629 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1630 if (precision == 0UL)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1631 bigfloat_init (bigfloat_data (f));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1632 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1633 bigfloat_init_prec (bigfloat_data (f), precision);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1634 bigfloat_set_double (bigfloat_data (f), float_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1635 return wrap_bigfloat (f);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1636 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1637
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1638 /* This function creates a bigfloat with the precision of its argument */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1639 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1640 make_bigfloat_bf (bigfloat float_value)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1641 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1642 Lisp_Bigfloat *f;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1643
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1644 ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1645 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1646 bigfloat_set (bigfloat_data (f), float_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1647 return wrap_bigfloat (f);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1648 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1649 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1650
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1651 /************************************************************************/
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1652 /* Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 mark_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 Lisp_Vector *ptr = XVECTOR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 int len = vector_length (ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 for (i = 0; i < len - 1; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 mark_object (ptr->contents[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664 return (len > 0) ? ptr->contents[len - 1] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1667 static Bytecount
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1668 size_vector (Lisp_Object obj)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1669 {
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1670
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1671 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1672 XVECTOR (obj)->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 static int
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
1676 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 int len = XVECTOR_LENGTH (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 if (len != XVECTOR_LENGTH (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 while (len--)
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
1686 if (!internal_equal_0 (*ptr1++, *ptr2++, depth + 1, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1692 static Hashcode
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1693 vector_hash (Lisp_Object obj, int depth)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1694 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1695 return HASH2 (XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1696 internal_array_hash (XVECTOR_DATA (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1697 XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1698 depth + 1));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1699 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1700
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1701 static const struct memory_description vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1702 { XD_LONG, offsetof (Lisp_Vector, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1703 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1706
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1707 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("vector", vector,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1708 mark_vector, print_vector, 0,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1709 vector_equal,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1710 vector_hash,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1711 vector_description,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
1712 size_vector, Lisp_Vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 /* #### should allocate `small' vectors from a frob-block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 static Lisp_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1715 make_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1717 /* no `next' field; we use lcrecords */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1718 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1719 contents, sizei);
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
1720 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, vector);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
1721 Lisp_Vector *p = XVECTOR (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 p->size = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1728 make_vector (Elemcount length, Lisp_Object object)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 Lisp_Vector *vecp = make_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733 while (length--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1734 *p++ = object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1736 return wrap_vector (vecp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1740 Return a new vector of length LENGTH, with each element being OBJECT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 See also the function `vector'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1743 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 CONCHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1746 return make_vector (XINT (length), object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 DEFUN ("vector", Fvector, 0, MANY, 0, /*
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1750 Return a newly created vector with specified ARGS as elements.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 Any number of arguments, even zero arguments, are allowed.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1752
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1753 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 Lisp_Vector *vecp = make_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 while (nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 *p++ = *args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1763 return wrap_vector (vecp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 vector1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 return Fvector (1, &obj0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 vector2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 return Fvector (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 return Fvector (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 #if 0 /* currently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 return Fvector (4, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 Lisp_Object obj3, Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 return Fvector (5, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 return Fvector (6, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835 Lisp_Object obj6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 return Fvector (7, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 Lisp_Object obj6, Lisp_Object obj7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 args[7] = obj7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 return Fvector (8, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 #endif /* unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 /* Bit Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 /* #### should allocate `small' bit vectors from a frob-block */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1871 static Lisp_Bit_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1872 make_bit_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1874 /* no `next' field; we use lcrecords */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1875 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1876 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1877 unsigned long,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1878 bits, num_longs);
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
1879 Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, bit_vector);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
1880 Lisp_Bit_Vector *p = XBIT_VECTOR (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 bit_vector_length (p) = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1887 make_bit_vector (Elemcount length, Lisp_Object bit)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1889 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1890 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1892 CHECK_BIT (bit);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1893
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1894 if (ZEROP (bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 memset (p->bits, 0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1898 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 memset (p->bits, ~0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 /* But we have to make sure that the unused bits in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 last long are 0, so that equal/hash is easy. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902 if (bits_in_last)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1906 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1910 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1912 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 for (i = 0; i < length; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 set_bit_vector_bit (p, i, bytevec[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1918 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1922 Return a new bit vector of length LENGTH. with each bit set to BIT.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1923 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1925 (length, bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 CONCHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1929 return make_bit_vector (XINT (length), bit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1933 Return a newly created bit vector with specified ARGS as elements.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 Any number of arguments, even zero arguments, are allowed.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1935 Each argument must be one of the integers 0 or 1.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1936
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1937 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 CHECK_BIT (args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 set_bit_vector_bit (p, i, !ZEROP (args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1950 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 /* Compiled-function allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 make_compiled_function (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
1966 ALLOC_FROB_BLOCK_LISP_OBJECT (compiled_function, Lisp_Compiled_Function,
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
1967 f, &lrecord_compiled_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 f->stack_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 f->specpdl_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971 f->flags.documentationp = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 f->flags.interactivep = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 f->flags.domainp = 0; /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 f->instructions = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 f->constants = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 f->arglist = Qnil;
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
1977 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
1978 f->arguments = Qnil;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
1979 #else /* not NEW_GC */
1739
9ddedfc70c4a [xemacs-hg @ 2003-10-10 18:04:23 by james]
james
parents: 1737
diff changeset
1980 f->args = NULL;
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
1981 #endif /* not NEW_GC */
1739
9ddedfc70c4a [xemacs-hg @ 2003-10-10 18:04:23 by james]
james
parents: 1737
diff changeset
1982 f->max_args = f->min_args = f->args_in_array = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 f->annotated = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 #endif
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1987 return wrap_compiled_function (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 Return a new compiled-function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 Note that, unlike all other emacs-lisp functions, calling this with five
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 arguments is NOT the same as calling it with six arguments, the last of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 which is nil. If the INTERACTIVE arg is specified as nil, then that means
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 that this function was defined with `(interactive)'. If the arg is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996 specified, then that means the function is not interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 This is terrible behavior which is retained for compatibility with old
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 `.elc' files which expect these semantics.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
1999
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
2000 arguments: (ARGLIST INSTRUCTIONS CONSTANTS STACK-DEPTH &optional DOC-STRING INTERACTIVE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 /* In a non-insane world this function would have this arglist...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 (arglist instructions constants stack_depth &optional doc_string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 Lisp_Object fun = make_compiled_function ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 Lisp_Object arglist = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011 Lisp_Object instructions = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 Lisp_Object constants = args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 Lisp_Object stack_depth = args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 if (nargs < 4 || nargs > 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 return Fsignal (Qwrong_number_of_arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 list2 (intern ("make-byte-code"), make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 /* Check for valid formal parameter list now, to allow us to use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2024 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 if (EQ (symbol, Qt) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 EQ (symbol, Qnil) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 SYMBOL_IS_KEYWORD (symbol))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
2030 invalid_constant_2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 ("Invalid constant symbol in formal parameter list",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 symbol, arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 f->arglist = arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 /* `instructions' is a string or a cons (string . int) for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 lazy-loaded function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 if (CONSP (instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 CHECK_STRING (XCAR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 CHECK_INT (XCDR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 CHECK_STRING (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 f->instructions = instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 if (!NILP (constants))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 f->constants = constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 CHECK_NATNUM (stack_depth);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2055 f->stack_depth = (unsigned short) XINT (stack_depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
4923
8ee3c10d1ed5 remove old no-longer-useful kludgy compiled-fun annotations hack
Ben Wing <ben@xemacs.org>
parents: 4921
diff changeset
2058 f->annotated = Vload_file_name_internal;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 /* doc_string may be nil, string, int, or a cons (string . int).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 interactive may be list or string (or unbound). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063 f->doc_and_interactive = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 f->doc_and_interactive = Vfile_domain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 Fcons (interactive, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 Fcons (doc_string, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 if (UNBOUNDP (f->doc_and_interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088 /* Symbol allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2091 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 Return a newly allocated uninterned symbol whose name is NAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 Its value and function definition are void, and its property list is nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098 (name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2100 Lisp_Symbol *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 CHECK_STRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2104 ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2105 p->name = name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 p->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2107 p->value = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2108 p->function = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109 symbol_next (p) = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2110 return wrap_symbol (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 /* Extent allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2116 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 struct extent *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122 allocate_extent (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2123 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2124 struct extent *e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2126 ALLOC_FROB_BLOCK_LISP_OBJECT (extent, struct extent, e, &lrecord_extent);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 extent_object (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2128 set_extent_start (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 set_extent_end (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130 e->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 xzero (e->flags);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 extent_face (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2136 e->flags.detachable = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2138 return e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 /* Event allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2146 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2149 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 allocate_event (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2151 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2152 Lisp_Event *e;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2153
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2154 ALLOC_FROB_BLOCK_LISP_OBJECT (event, Lisp_Event, e, &lrecord_event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2155
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2156 return wrap_event (e);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2159 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2160 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2161 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2162
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2163 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2164 make_key_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2165 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2166 Lisp_Key_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2167
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2168 ALLOC_FROB_BLOCK_LISP_OBJECT (key_data, Lisp_Key_Data, d,
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2169 &lrecord_key_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2170 zero_nonsized_lisp_object (wrap_key_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2171 d->keysym = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2172
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2173 return wrap_key_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2174 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2175
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2176 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2177 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2178
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2179 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2180 make_button_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2181 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2182 Lisp_Button_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2183
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2184 ALLOC_FROB_BLOCK_LISP_OBJECT (button_data, Lisp_Button_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2185 &lrecord_button_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2186 zero_nonsized_lisp_object (wrap_button_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2187 return wrap_button_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2188 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2189
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2190 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2191 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2192
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2193 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2194 make_motion_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2195 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2196 Lisp_Motion_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2197
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2198 ALLOC_FROB_BLOCK_LISP_OBJECT (motion_data, Lisp_Motion_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2199 &lrecord_motion_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2200 zero_nonsized_lisp_object (wrap_motion_data (d));
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2201
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2202 return wrap_motion_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2203 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2204
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2205 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2206 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2207
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2208 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2209 make_process_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2210 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2211 Lisp_Process_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2212
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2213 ALLOC_FROB_BLOCK_LISP_OBJECT (process_data, Lisp_Process_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2214 &lrecord_process_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2215 zero_nonsized_lisp_object (wrap_process_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2216 d->process = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2217
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2218 return wrap_process_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2219 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2220
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2221 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2222 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2223
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2224 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2225 make_timeout_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2226 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2227 Lisp_Timeout_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2228
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2229 ALLOC_FROB_BLOCK_LISP_OBJECT (timeout_data, Lisp_Timeout_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2230 &lrecord_timeout_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2231 zero_nonsized_lisp_object (wrap_timeout_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2232 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2233 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2234
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2235 return wrap_timeout_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2236 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2237
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2238 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2239 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2240
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2241 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2242 make_magic_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2243 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2244 Lisp_Magic_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2245
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2246 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_data, Lisp_Magic_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2247 &lrecord_magic_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2248 zero_nonsized_lisp_object (wrap_magic_data (d));
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2249
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2250 return wrap_magic_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2251 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2252
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2253 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2254 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2255
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2256 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2257 make_magic_eval_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2258 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2259 Lisp_Magic_Eval_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2260
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2261 ALLOC_FROB_BLOCK_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2262 &lrecord_magic_eval_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2263 zero_nonsized_lisp_object (wrap_magic_eval_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2264 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2265
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2266 return wrap_magic_eval_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2267 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2268
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2269 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2270 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2271
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2272 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2273 make_eval_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2274 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2275 Lisp_Eval_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2276
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2277 ALLOC_FROB_BLOCK_LISP_OBJECT (eval_data, Lisp_Eval_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2278 &lrecord_eval_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2279 zero_nonsized_lisp_object (wrap_eval_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2280 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2281 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2282
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2283 return wrap_eval_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2284 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2285
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2286 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2287 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2288
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2289 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2290 make_misc_user_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2291 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2292 Lisp_Misc_User_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2293
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2294 ALLOC_FROB_BLOCK_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data, d,
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2295 &lrecord_misc_user_data);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2296 zero_nonsized_lisp_object (wrap_misc_user_data (d));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2297 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2298 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2299
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2300 return wrap_misc_user_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2301 }
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2302
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2303 #endif /* EVENT_DATA_AS_OBJECTS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306 /* Marker allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2309 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 Return a new marker which does not point at any place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2317 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2318
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2319 ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2321 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2325 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 noseeum_make_marker (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2331 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2332
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2333 NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p,
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
2334 &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2336 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2340 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345 /* String allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2348 /* The data for "short" strings generally resides inside of structs of type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2349 string_chars_block. The Lisp_String structure is allocated just like any
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2350 other frob-block lrecord, and these are freelisted when they get garbage
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2351 collected. The data for short strings get compacted, but the data for
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2352 large strings do not.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 Previously Lisp_String structures were relocated, but this caused a lot
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355 of bus-errors because the C code didn't include enough GCPRO's for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2357 that the reference would get relocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 This new method makes things somewhat bigger, but it is MUCH safer. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2361 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2362 /* strings are used and freed quite often */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2363 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2367 mark_string (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2369 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj))))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2370 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj)));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2371 return XSTRING_PLIST (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374 static int
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2375 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2376 int foldcase)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 Bytecount len;
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2379 if (foldcase)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2380 return !lisp_strcasecmp_i18n (obj1, obj2);
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2381 else
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2382 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
2383 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2386 static const struct memory_description string_description[] = {
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2387 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2388 { XD_LISP_OBJECT, offsetof (Lisp_String, data_object) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2389 #else /* not NEW_GC */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2390 { XD_BYTECOUNT, offsetof (Lisp_String, size_) },
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2391 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) },
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2392 #endif /* not NEW_GC */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2393 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2397 /* We store the string's extent info as the first element of the string's
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2398 property list; and the string's MODIFF as the first or second element
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2399 of the string's property list (depending on whether the extent info
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2400 is present), but only if the string has been modified. This is ugly
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2401 but it reduces the memory allocated for the string in the vast
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2402 majority of cases, where the string is never modified and has no
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2403 extent info.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2404
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2405 #### This means you can't use an int as a key in a string's plist. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2406
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2407 static Lisp_Object *
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2408 string_plist_ptr (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2409 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2410 Lisp_Object *ptr = &XSTRING_PLIST (string);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2411
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2412 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2413 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2414 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2415 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2416 return ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2417 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2418
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2419 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2420 string_getprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2421 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2422 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2423 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2424
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2425 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2426 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2427 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2428 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2429 return 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2430 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2431
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2432 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2433 string_remprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2434 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2435 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2436 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2437
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2438 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2439 string_plist (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2440 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2441 return *string_plist_ptr (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2442 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2443
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2444 #ifndef NEW_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2445 /* No `finalize', or `hash' methods.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2446 internal_hash() already knows how to hash strings and finalization
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2447 is done with the ADDITIONAL_FREE_string macro, which is the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2448 standard way to do finalization when using
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2449 SWEEP_FIXED_TYPE_BLOCK(). */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2450
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2451 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("string", string,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2452 mark_string, print_string,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2453 0, string_equal, 0,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2454 string_description,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2455 Lisp_String);
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2456 #endif /* not NEW_GC */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2457
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2458 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2459 #define STRING_FULLSIZE(size) \
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2460 ALIGN_SIZE (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_String_Direct_Data, Lisp_Object, data, (size) + 1), sizeof (Lisp_Object *));
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2461 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 /* String blocks contain this many useful bytes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 #define STRING_CHARS_BLOCK_SIZE \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2464 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2465 ((2 * sizeof (struct string_chars_block *)) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2466 + sizeof (EMACS_INT))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 /* Block header for small strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 struct string_chars_block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 EMACS_INT pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 struct string_chars_block *next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 struct string_chars_block *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 /* Contents of string_chars_block->string_chars are interleaved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 string_chars structures (see below) and the actual string data */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 static struct string_chars_block *first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 static struct string_chars_block *current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481 /* If SIZE is the length of a string, this returns how many bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482 * the string occupies in string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 * (including alignment padding).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2485 #define STRING_FULLSIZE(size) \
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2486 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2491 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2492 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2493 #endif /* not NEW_GC */
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2494
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2495 #ifdef NEW_GC
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2496 DEFINE_DUMPABLE_LISP_OBJECT ("string", string, mark_string, print_string,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2497 0, string_equal, 0,
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
2498 string_description, Lisp_String);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2499
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2500
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2501 static const struct memory_description string_direct_data_description[] = {
3514
8b1d806afbb3 [xemacs-hg @ 2006-07-18 15:01:27 by crestani]
crestani
parents: 3461
diff changeset
2502 { XD_BYTECOUNT, offsetof (Lisp_String_Direct_Data, size) },
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2503 { XD_END }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2504 };
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2505
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2506 static Bytecount
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2507 size_string_direct_data (Lisp_Object obj)
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2508 {
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2509 return STRING_FULLSIZE (XSTRING_DIRECT_DATA (obj)->size);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2510 }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2511
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2512
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2513 DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("string-direct-data",
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2514 string_direct_data,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2515 0,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2516 string_direct_data_description,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2517 size_string_direct_data,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2518 Lisp_String_Direct_Data);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2519
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2520
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2521 static const struct memory_description string_indirect_data_description[] = {
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2522 { XD_BYTECOUNT, offsetof (Lisp_String_Indirect_Data, size) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2523 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String_Indirect_Data, data),
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2524 XD_INDIRECT(0, 1) },
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2525 { XD_END }
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2526 };
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2527
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2528 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("string-indirect-data",
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2529 string_indirect_data,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2530 0,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2531 string_indirect_data_description,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2532 Lisp_String_Indirect_Data);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2533 #endif /* NEW_GC */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2534
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2535 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2538 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2544 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545 EMACS_INT fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 init_string_chars_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2553 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 current_string_chars_block = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2556 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2557
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2558 static Ibyte *
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2559 allocate_big_string_chars (Bytecount length)
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2560 {
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2561 Ibyte *p = xnew_array (Ibyte, length);
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2562 INCREMENT_CONS_COUNTER (length, "string chars");
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2563 return p;
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2564 }
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2565
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566 static struct string_chars *
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2567 allocate_string_chars_struct (Lisp_Object string_it_goes_with,
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2568 Bytecount fullsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2569 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2571
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2572 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2573 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2574 - current_string_chars_block->pos))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2575 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2577 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 current_string_chars_block->pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2581 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2584 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 struct string_chars_block *new_scb = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2586
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2587 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2588 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2592 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2596 s_chars->string = XSTRING (string_it_goes_with);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 INCREMENT_CONS_COUNTER (fullsize, "string chars");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600 return s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 }
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2602 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2604 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2605 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2606 sledgehammer_check_ascii_begin (Lisp_Object str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2607 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2608 Bytecount i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2609
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2610 for (i = 0; i < XSTRING_LENGTH (str); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2611 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2612 if (!byte_ascii_p (string_byte (str, i)))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2613 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2614 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2615
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2616 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) ||
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2617 (i > MAX_STRING_ASCII_BEGIN &&
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2618 (Bytecount) XSTRING_ASCII_BEGIN (str) ==
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2619 (Bytecount) MAX_STRING_ASCII_BEGIN));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2620 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2621 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2622
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2623 /* You do NOT want to be calling this! (And if you do, you must call
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
2624 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA ()
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2625 instead and then call make_string() like the rest of the world. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2626
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 make_uninit_string (Bytecount length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2630 Lisp_String *s;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2631 Bytecount fullsize = STRING_FULLSIZE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2633 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2635 #ifdef NEW_GC
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
2636 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string));
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2637 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2639 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2640 xzero (*s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2641 set_lheader_implementation (&s->u.lheader, &lrecord_string);
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2642 #endif /* not NEW_GC */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2643
3063
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2644 /* The above allocations set the UID field, which overlaps with the
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2645 ascii-length field, to some non-zero value. We need to zero it. */
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2646 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0);
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2647
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2648 #ifdef NEW_GC
3304
73051095a712 [xemacs-hg @ 2006-03-26 14:33:37 by crestani]
crestani
parents: 3263
diff changeset
2649 set_lispstringp_direct (s);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2650 STRING_DATA_OBJECT (s) =
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
2651 alloc_sized_lrecord (fullsize, &lrecord_string_direct_data);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2652 #else /* not NEW_GC */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2653 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2654 ? allocate_big_string_chars (length + 1)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2655 : allocate_string_chars_struct (wrap_string (s),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2656 fullsize)->chars);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2657 #endif /* not NEW_GC */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2658
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2659 set_lispstringp_length (s, length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 s->plist = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2661 set_string_byte (wrap_string (s), length, 0);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2662
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2663 return wrap_string (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2664 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673 this if you're planning on completely overwriting the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2677 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 {
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2679 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2680 Bytecount newfullsize, len;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2681 #else /* not NEW_GC */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2682 Bytecount oldfullsize, newfullsize;
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2683 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2686 #endif
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2687 #ifdef ERROR_CHECK_TEXT
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2689 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2690 assert (pos <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2692 assert (pos + (-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2697 assert ((-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2699 #endif /* ERROR_CHECK_TEXT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2701 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2702 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2703 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2704
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2705 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2706 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2707 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2708 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2709 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2710
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2711 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2712 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2713
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2714 len = XSTRING_LENGTH (s) + 1 - pos;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2715
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2716 if (delta < 0 && pos >= 0)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2717 memmove (XSTRING_DATA (s) + pos + delta,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2718 XSTRING_DATA (s) + pos, len);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2719
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2720 XSTRING_DATA_OBJECT (s) =
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2721 wrap_string_direct_data (mc_realloc (XPNTR (XSTRING_DATA_OBJECT (s)),
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2722 newfullsize));
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2723 if (delta > 0 && pos >= 0)
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2724 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos,
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2725 len);
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2726
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
2727 #else /* not NEW_GC */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2728 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2729 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2730
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2731 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2733 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2735 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2736 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2737 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2738 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2739 illegal, and we might crash. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2740 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2741
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2742 if (delta < 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2743 memmove (XSTRING_DATA (s) + pos + delta,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2744 XSTRING_DATA (s) + pos, len);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2745 XSET_STRING_DATA
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2746 (s, (Ibyte *) xrealloc (XSTRING_DATA (s),
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2747 XSTRING_LENGTH (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2748 if (delta > 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2749 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2750 len);
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2751 /* Bump the cons counter.
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2752 Conservative; Martin let the increment be delta. */
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2753 INCREMENT_CONS_COUNTER (newfullsize, "string chars");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2755 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2757 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2758 allocate_string_chars_struct (s, newfullsize)->chars;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2759 Ibyte *old_data = XSTRING_DATA (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2760
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2761 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2762 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2763 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2764 memcpy (new_data + pos + delta, old_data + pos,
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2765 XSTRING_LENGTH (s) + 1 - pos);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2766 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2767 XSET_STRING_DATA (s, new_data);
4976
16112448d484 Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents: 4969
diff changeset
2768 xfree (old_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2769 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2770 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2771 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2772 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2773 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2774 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2775 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2776 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2777 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2778 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2779 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2782 Ibyte *addroff = pos + XSTRING_DATA (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785 /* +1 due to zero-termination. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2786 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2791 Ibyte *old_data = XSTRING_DATA (s);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2792 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2793 BIG_STRING_FULLSIZE_P (newfullsize)
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2794 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2795 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2796
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2799 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2800 memcpy (new_data + pos + delta, old_data + pos,
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2801 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2803 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2804
4776
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2805 if (!DUMPEDP (old_data)) /* Can't free dumped data. */
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2806 {
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2807 /* We need to mark this chunk of the string_chars_block
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2808 as unused so that compact_string_chars() doesn't
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2809 freak. */
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2810 struct string_chars *old_s_chars = (struct string_chars *)
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2811 ((char *) old_data - offsetof (struct string_chars, chars));
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2812 /* Sanity check to make sure we aren't hosed by strange
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2813 alignment/padding. */
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2814 assert (old_s_chars->string == XSTRING (s));
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2815 MARK_STRING_CHARS_AS_FREE (old_s_chars);
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2816 ((struct unused_string_chars *) old_s_chars)->fullsize =
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2817 oldfullsize;
73e8632018ad Don't attempt to free dumped data, alloc.c:resize_string()
Aidan Kehoe <kehoea@parhasard.net>
parents: 4735
diff changeset
2818 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2820 }
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
2821 #endif /* not NEW_GC */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2822
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2823 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2824 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2825 Terminate now just to make sure. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2826 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2827
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2828 if (pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2829 /* We also have to adjust all of the extent indices after the
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2830 place we did the change. We say "pos - 1" because
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2831 adjust_extents() is exclusive of the starting position
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2832 passed to it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2833 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2842 /* WARNING: If you modify an existing string, you must call
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2843 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 void
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2845 set_string_char (Lisp_Object s, Charcount i, Ichar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2847 Ibyte newstr[MAX_ICHAR_LEN];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2848 Bytecount bytoff = string_index_char_to_byte (s, i);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2849 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2850 Bytecount newlen = set_itext_ichar (newstr, c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2852 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 resize_string (s, bytoff, newlen - oldlen);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2855 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2856 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2857 if (oldlen != newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2858 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2859 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2860 /* Everything starting with the new char is no longer part of
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2861 ascii_begin */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2862 XSET_STRING_ASCII_BEGIN (s, i);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2863 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2864 /* We've extended ascii_begin, and we have to figure out how much by */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2865 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2866 Bytecount j;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2867 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2868 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2869 if (!byte_ascii_p (XSTRING_DATA (s)[j]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2870 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2871 }
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2872 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2873 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2874 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2875 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2881 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2882 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2884 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2887 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2889 Ibyte init_str[MAX_ICHAR_LEN];
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2890 int len = set_itext_ichar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 if (len == 1)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2894 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2895 /* Optimize the single-byte case */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2896 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2897 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2898 len * XINT (length)));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2899 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2902 EMACS_INT i;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2903 Ibyte *ptr = XSTRING_DATA (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2907 Ibyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2908 switch (len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2909 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 case 1: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2917 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 Concatenate all the argument characters and make the result a string.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
2924
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3514
diff changeset
2925 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2928 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2929 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2930 Ibyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2932 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2935 CHECK_CHAR_COERCE_INT (lisp_char);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2936 p += set_itext_ichar (p, XCHAR (lisp_char));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2937 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2938 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2941 /* Initialize the ascii_begin member of a string to the correct value. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2942
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2943 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2944 init_string_ascii_begin (Lisp_Object string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2945 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2946 #ifdef MULE
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2947 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2948 Bytecount length = XSTRING_LENGTH (string);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2949 Ibyte *contents = XSTRING_DATA (string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2950
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2951 for (i = 0; i < length; i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2952 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2953 if (!byte_ascii_p (contents[i]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2954 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2955 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2956 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2957 #else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2958 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2959 MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2960 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2961 sledgehammer_check_ascii_begin (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2962 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2964 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2965 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2967 make_string (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2971 /* Make sure we find out about bad make_string's when they happen */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2972 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2973 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2977 memcpy (XSTRING_DATA (val), contents, length);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2978 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2979 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2984 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2985 Lisp_Object
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
2986 make_extstring (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2987 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2988 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2989 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2990 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2991 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2992 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2993 return string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2994 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2996 Lisp_Object
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
2997 build_istring (const Ibyte *str)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2998 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2999 /* Some strlen's crash and burn if passed null. */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
3000 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3001 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3002
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3003 Lisp_Object
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3004 build_cistring (const CIbyte *str)
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3005 {
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3006 return build_istring ((const Ibyte *) str);
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3007 }
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3008
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3009 Lisp_Object
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3010 build_ascstring (const Ascbyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3011 {
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3012 ASSERT_ASCTEXT_ASCII (str);
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3013 return build_istring ((const Ibyte *) str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016 Lisp_Object
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3017 build_extstring (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3018 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3019 /* Some strlen's crash and burn if passed null. */
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3020 return make_extstring ((const Extbyte *) str,
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3021 (str ? dfc_external_data_len (str, coding_system) :
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3022 0),
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3023 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3026 /* Build a string whose content is a translatable message, and translate
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3027 the message according to the current language environment. */
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3028
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3029 Lisp_Object
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3030 build_msg_istring (const Ibyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3031 {
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3032 return build_istring (IGETTEXT (str));
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3033 }
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3034
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3035 /* Build a string whose content is a translatable message, and translate
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3036 the message according to the current language environment. */
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3037
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3038 Lisp_Object
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3039 build_msg_cistring (const CIbyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3040 {
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3041 return build_msg_istring ((const Ibyte *) str);
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3042 }
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3043
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3044 /* Build a string whose content is a translatable message, and translate
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3045 the message according to the current language environment.
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3046 String must be pure-ASCII, and when compiled with error-checking,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3047 an abort will have if not pure-ASCII. */
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3048
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3049 Lisp_Object
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3050 build_msg_ascstring (const Ascbyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3051 {
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3052 ASSERT_ASCTEXT_ASCII (str);
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3053 return build_msg_istring ((const Ibyte *) str);
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3054 }
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3055
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3056 /* Build a string whose content is a translatable message, but don't
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3057 translate the message immediately. Perhaps do something else instead,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3058 such as put a property on the string indicating that it needs to be
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3059 translated.
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3060
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3061 This is useful for strings that are built at dump time or init time,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3062 rather than on-the-fly when the current language environment is set
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3063 properly. */
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3064
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3065 Lisp_Object
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3066 build_defer_istring (const Ibyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3067 {
4953
304aebb79cd3 function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents: 4952
diff changeset
3068 Lisp_Object retval = build_istring ((Ibyte *) str);
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3069 /* Possibly do something to the return value */
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3070 return retval;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3071 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3072
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 Lisp_Object
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3074 build_defer_cistring (const CIbyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3075 {
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3076 return build_defer_istring ((Ibyte *) str);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3077 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3078
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3079 Lisp_Object
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3080 build_defer_ascstring (const Ascbyte *str)
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3081 {
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3082 ASSERT_ASCTEXT_ASCII (str);
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3083 return build_defer_istring ((Ibyte *) str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
3087 make_string_nocopy (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3089 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 /* Make sure we find out about bad make_string_nocopy's when they happen */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
3093 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3097 #ifdef NEW_GC
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3098 s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3099 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3100 collected and static data is tried to
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3101 be freed. */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3102 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3104 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3105 set_lheader_implementation (&s->u.lheader, &lrecord_string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3106 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3107 #endif /* not NEW_GC */
3063
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
3108 /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
3109 init_string_ascii_begin(). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 s->plist = Qnil;
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3111 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3112 set_lispstringp_indirect (s);
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3113 STRING_DATA_OBJECT (s) = ALLOC_NORMAL_LISP_OBJECT (string_indirect_data);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3114 XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3115 XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length;
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3116 #else /* not NEW_GC */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
3117 set_lispstringp_data (s, (Ibyte *) contents);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3118 set_lispstringp_length (s, length);
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
3119 #endif /* not NEW_GC */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3120 val = wrap_string (s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3121 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3122 sledgehammer_check_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3123
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3128 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 /* Lcrecord lists are used to manage the allocation of particular
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3134 sorts of lcrecords, to avoid calling ALLOC_NORMAL_LISP_OBJECT() (and thus
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3138 See detailed comment in lcrecord.h.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3139 */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3140
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3141 const struct memory_description free_description[] = {
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3142 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 },
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3143 XD_FLAG_FREE_LISP_OBJECT },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3144 { XD_END }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3145 };
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3146
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3147 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("free", free, 0, free_description,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3148 struct free_lcrecord_header);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3149
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3150 const struct memory_description lcrecord_list_description[] = {
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3151 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 },
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3152 XD_FLAG_FREE_LISP_OBJECT },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3153 { XD_END }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3154 };
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3158 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3159 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3160 Lisp_Object chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 while (!NILP (chain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3168 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3169 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3170 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3171 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3172 /* Only lcrecords should be here. */
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3173 ! list->implementation->frob_block_p
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3174 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3175 /* Only free lcrecords should be here. */
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3176 lheader->free
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3177 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3178 /* The type of the lcrecord must be right. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3179 lheader->type == lrecord_type_free
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3180 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3181 /* So must the size. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3182 (list->implementation->static_size == 0 ||
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3183 list->implementation->static_size == list->size)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3184 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3185
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3193 DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("lcrecord-list", lcrecord_list,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3194 mark_lcrecord_list,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3195 lcrecord_list_description,
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4776
diff changeset
3196 struct lcrecord_list);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3197
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3199 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3200 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 {
5124
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5120
diff changeset
3202 /* Don't use alloc_automanaged_lcrecord() avoid infinite recursion
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5120
diff changeset
3203 allocating this. */
5151
641d0cdd1d00 fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
3204 struct lcrecord_list *p =
641d0cdd1d00 fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
3205 XLCRECORD_LIST (old_alloc_lcrecord (&lrecord_lcrecord_list));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 p->free = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3210 return wrap_lcrecord_list (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3214 alloc_managed_lcrecord (Lisp_Object lcrecord_list)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 if (!NILP (list->free))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3221 (struct free_lcrecord_header *) XPNTR (val);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3222 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224 #ifdef ERROR_CHECK_GC
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3225 /* Major overkill here. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3227 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 /* Only free lcrecords should be here. */
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3229 assert (lheader->free);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3230 assert (lheader->type == lrecord_type_free);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3231 /* Only lcrecords should be here. */
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3232 assert (! (list->implementation->frob_block_p));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3233 #if 0 /* Not used anymore, now that we set the type of the header to
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3234 lrecord_type_free. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3235 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3236 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3237 #endif /* 0 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238 /* So must the size. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3239 assert (list->implementation->static_size == 0 ||
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3240 list->implementation->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3242
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243 list->free = free_header->chain;
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3244 lheader->free = 0;
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3245 /* Put back the correct type, as we set it to lrecord_type_free. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3246 lheader->type = list->implementation->lrecord_type_index;
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3247 zero_sized_lisp_object (val, list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250 else
5151
641d0cdd1d00 fix compilation problems identified by Robert Delius Royar
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
3251 return old_alloc_sized_lcrecord (list->size, list->implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3254 /* "Free" a Lisp object LCRECORD by placing it on its associated free list
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3255 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3256 same LCRECORD_LIST as its parameter, it will return an object from the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3257 free list, which may be this one. Be VERY VERY SURE there are no
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3258 pointers to this object hanging around anywhere where they might be
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3259 used!
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3260
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3261 The first thing this does before making any global state change is to
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3262 call the finalize method of the object, if it exists. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3263
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3264 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3270 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3271 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3272 = LHEADER_IMPLEMENTATION (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3273
4880
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3274 /* If we try to debug-print during GC, we'll likely get a crash on the
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3275 following assert (called from Lstream_delete(), from prin1_to_string()).
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3276 Instead, just don't do anything. Worst comes to worst, we have a
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3277 small memory leak -- and programs being debugged usually won't be
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3278 super long-lived afterwards, anyway. */
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3279 if (gc_in_progress && in_debug_print)
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3280 return;
ae81a2c00f4f try harder to avoid crashing when debug-printing
Ben Wing <ben@xemacs.org>
parents: 4803
diff changeset
3281
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3282 /* Finalizer methods may try to free objects within them, which typically
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3283 won't be marked and thus are scheduled for demolition. Putting them
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3284 on the free list would be very bad, as we'd have xfree()d memory in
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3285 the list. Even if for some reason the objects are still live
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3286 (generally a logic error!), we still will have problems putting such
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3287 an object on the free list right now (e.g. we'd have to avoid calling
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3288 the finalizer twice, etc.). So basically, those finalizers should not
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3289 be freeing any objects if during GC. Abort now to catch those
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3290 problems. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3291 gc_checking_assert (!gc_in_progress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3292
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 /* Make sure the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 putting a window configuration on the wrong free list. */
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3295 gc_checking_assert (lisp_object_size (lcrecord) == list->size);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3296 /* Make sure the object isn't already freed. */
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3297 gc_checking_assert (!lheader->free);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3298 /* Freeing stuff in dumped memory is bad. If you trip this, you
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3299 may need to check for this before freeing. */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3300 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3301
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 if (implementation->finalizer)
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
3303 implementation->finalizer (lcrecord);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3304 /* Yes, there are two ways to indicate freeness -- the type is
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3305 lrecord_type_free or the ->free flag is set. We used to do only the
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3306 latter; now we do the former as well for KKCC purposes. Probably
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3307 safer in any case, as we will lose quicker this way than keeping
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3308 around an lrecord of apparently correct type but bogus junk in it. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3309 MARK_LRECORD_AS_FREE (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 free_header->chain = list->free;
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3311 lheader->free = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3315 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)];
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3316
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3317 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3318 alloc_automanaged_sized_lcrecord (Bytecount size,
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3319 const struct lrecord_implementation *imp)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3320 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3321 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3322 all_lcrecord_lists[imp->lrecord_type_index] =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3323 make_lcrecord_list (size, imp);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3324
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3325 return alloc_managed_lcrecord (all_lcrecord_lists[imp->lrecord_type_index]);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3326 }
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3327
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3328 Lisp_Object
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3329 alloc_automanaged_lcrecord (const struct lrecord_implementation *imp)
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3330 {
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3331 type_checking_assert (imp->static_size > 0);
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3063
diff changeset
3332 return alloc_automanaged_sized_lcrecord (imp->static_size, imp);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3333 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3334
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3335 void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3336 old_free_lcrecord (Lisp_Object rec)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3337 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3338 int type = XRECORD_LHEADER (rec)->type;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3339
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3340 assert (!EQ (all_lcrecord_lists[type], Qzero));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3341
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3342 free_managed_lcrecord (all_lcrecord_lists[type], rec);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3343 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3344 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3346
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3347 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3348 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3354 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3355 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3356 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 /************************************************************************/
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3361 /* Staticpro, MCpro */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3364 /* We want the staticpro list relocated, but not the pointers found
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3365 therein, because they refer to locations in the global data segment, not
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3366 in the heap; we only dump heap objects. Hence we use a trivial
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3367 description, as for pointerless objects. (Note that the data segment
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3368 objects, which are global variables like Qfoo or Vbar, themselves are
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3369 pointers to heap objects. Each needs to be described to pdump as a
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3370 "root pointer"; this happens in the call to staticpro(). */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3371 static const struct memory_description staticpro_description_1[] = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3372 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3373 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3374
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3375 static const struct sized_memory_description staticpro_description = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3376 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3377 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3378 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3379
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3380 static const struct memory_description staticpros_description_1[] = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3381 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3382 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3383 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3384
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3385 static const struct sized_memory_description staticpros_description = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3386 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3387 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3388 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3389
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3390 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3391
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3392 /* Help debug crashes gc-marking a staticpro'ed object. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3393
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3394 Lisp_Object_ptr_dynarr *staticpros;
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3395 const_Ascbyte_ptr_dynarr *staticpro_names;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3396
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3397 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3398 garbage collection, and for dumping. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3399 void
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3400 staticpro_1 (Lisp_Object *varaddress, const Ascbyte *varname)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3401 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3402 Dynarr_add (staticpros, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3403 Dynarr_add (staticpro_names, varname);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3404 dump_add_root_lisp_object (varaddress);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3405 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3406
5016
2ade80e8c640 enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents: 4976
diff changeset
3407 const Ascbyte *staticpro_name (int count);
2ade80e8c640 enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents: 4976
diff changeset
3408
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3409 /* External debugging function: Return the name of the variable at offset
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3410 COUNT. */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3411 const Ascbyte *
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3412 staticpro_name (int count)
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3413 {
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3414 return Dynarr_at (staticpro_names, count);
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3415 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3416
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3417 Lisp_Object_ptr_dynarr *staticpros_nodump;
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3418 const_Ascbyte_ptr_dynarr *staticpro_nodump_names;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3419
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3420 /* Mark the Lisp_Object at heap VARADDRESS as a root object for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3421 garbage collection, but not for dumping. (See below.) */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3422 void
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3423 staticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3424 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3425 Dynarr_add (staticpros_nodump, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3426 Dynarr_add (staticpro_nodump_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3427 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3428
5016
2ade80e8c640 enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents: 4976
diff changeset
3429 const Ascbyte *staticpro_nodump_name (int count);
2ade80e8c640 enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents: 4976
diff changeset
3430
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3431 /* External debugging function: Return the name of the variable at offset
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3432 COUNT. */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3433 const Ascbyte *
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3434 staticpro_nodump_name (int count)
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3435 {
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3436 return Dynarr_at (staticpro_nodump_names, count);
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3437 }
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3438
996
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3439 #ifdef HAVE_SHLIB
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3440 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3441 for garbage collection, but not for dumping. */
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3442 void
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3443 unstaticpro_nodump_1 (Lisp_Object *varaddress, const Ascbyte *varname)
996
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3444 {
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3445 Dynarr_delete_object (staticpros, varaddress);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3446 Dynarr_delete_object (staticpro_names, varname);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3447 }
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3448 #endif
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3449
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3450 #else /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3451
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3452 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3453
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3454 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3455 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3459 Dynarr_add (staticpros, varaddress);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3460 dump_add_root_lisp_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3463
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3464 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3465
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3466 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3467 collection, but not for dumping. This is used for objects where the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3468 only sure pointer is in the heap (rather than in the global data
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3469 segment, as must be the case for pdump root pointers), but not inside of
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3470 another Lisp object (where it will be marked as a result of that Lisp
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3471 object's mark method). The call to staticpro_nodump() must occur *BOTH*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3472 at initialization time and at "reinitialization" time (startup, after
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3473 pdump load.) (For example, this is the case with the predicate symbols
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3474 for specifier and coding system types. The pointer to this symbol is
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3475 inside of a methods structure, which is allocated on the heap. The
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3476 methods structure will be written out to the pdump data file, and may be
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3477 reloaded at a different address.)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3478
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3479 #### The necessity for reinitialization is a bug in pdump. Pdump should
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3480 automatically regenerate the staticpro()s for these symbols when it
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3481 loads the data in. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3482
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3486 Dynarr_add (staticpros_nodump, varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488
996
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3489 #ifdef HAVE_SHLIB
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3490 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3491 garbage collection, but not for dumping. */
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3492 void
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3493 unstaticpro_nodump (Lisp_Object *varaddress)
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3494 {
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3495 Dynarr_delete_object (staticpros, varaddress);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3496 }
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3497 #endif
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3498
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3499 #endif /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3500
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3501 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3502 static const struct memory_description mcpro_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3503 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3504 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3505
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3506 static const struct sized_memory_description mcpro_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3507 sizeof (Lisp_Object *),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3508 mcpro_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3509 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3510
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3511 static const struct memory_description mcpros_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3512 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3513 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3514 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3515
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3516 static const struct sized_memory_description mcpros_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3517 sizeof (Lisp_Object_dynarr),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3518 mcpros_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3519 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3520
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3521 #ifdef DEBUG_XEMACS
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3522
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3523 /* Help debug crashes gc-marking a mcpro'ed object. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3524
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3525 Lisp_Object_dynarr *mcpros;
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3526 const_Ascbyte_ptr_dynarr *mcpro_names;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3527
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3528 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3529 garbage collection, and for dumping. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3530 void
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3531 mcpro_1 (Lisp_Object varaddress, const Ascbyte *varname)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3532 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3533 Dynarr_add (mcpros, varaddress);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3534 Dynarr_add (mcpro_names, varname);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3535 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3536
5046
d4f666cda5e6 some random fixups
Ben Wing <ben@xemacs.org>
parents: 5016
diff changeset
3537 const Ascbyte *mcpro_name (int count);
d4f666cda5e6 some random fixups
Ben Wing <ben@xemacs.org>
parents: 5016
diff changeset
3538
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3539 /* External debugging function: Return the name of the variable at offset
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3540 COUNT. */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
3541 const Ascbyte *
4934
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3542 mcpro_name (int count)
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3543 {
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3544 return Dynarr_at (mcpro_names, count);
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3545 }
714f7c9fabb1 make it easier to debug staticpro crashes.
Ben Wing <ben@xemacs.org>
parents: 4880
diff changeset
3546
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3547 #else /* not DEBUG_XEMACS */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3548
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3549 Lisp_Object_dynarr *mcpros;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3550
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3551 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3552 garbage collection, and for dumping. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3553 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3554 mcpro (Lisp_Object varaddress)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3555 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3556 Dynarr_add (mcpros, varaddress);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3557 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3558
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3559 #endif /* not DEBUG_XEMACS */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3560 #endif /* NEW_GC */
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
3561
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3562 #ifdef ALLOC_TYPE_STATS
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3564
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3565 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3566 /* Determining allocation overhead */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3567 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3568
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3569 /* Attempt to determine the actual amount of space that is used for
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3570 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3571
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3572 It seems that the following holds:
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3573
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3574 1. When using the old allocator (malloc.c):
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3575
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3576 -- blocks are always allocated in chunks of powers of two. For
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3577 each block, there is an overhead of 8 bytes if rcheck is not
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3578 defined, 20 bytes if it is defined. In other words, a
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3579 one-byte allocation needs 8 bytes of overhead for a total of
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3580 9 bytes, and needs to have 16 bytes of memory chunked out for
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3581 it.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3582
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3583 2. When using the new allocator (gmalloc.c):
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3584
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3585 -- blocks are always allocated in chunks of powers of two up
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3586 to 4096 bytes. Larger blocks are allocated in chunks of
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3587 an integral multiple of 4096 bytes. The minimum block
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3588 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3589 is defined. There is no per-block overhead, but there
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3590 is an overhead of 3*sizeof (size_t) for each 4096 bytes
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3591 allocated.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3592
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3593 3. When using the system malloc, anything goes, but they are
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3594 generally slower and more space-efficient than the GNU
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3595 allocators. One possibly reasonable assumption to make
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3596 for want of better data is that sizeof (void *), or maybe
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3597 2 * sizeof (void *), is required as overhead and that
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3598 blocks are allocated in the minimum required size except
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3599 that some minimum block size is imposed (e.g. 16 bytes). */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3600
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3601 Bytecount
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3602 malloced_storage_size (void * UNUSED (ptr), Bytecount claimed_size,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3603 struct usage_stats *stats)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3604 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3605 Bytecount orig_claimed_size = claimed_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3606
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3607 #ifndef SYSTEM_MALLOC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3608 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3609 claimed_size = 2 * sizeof (void *);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3610 # ifdef SUNOS_LOCALTIME_BUG
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3611 if (claimed_size < 16)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3612 claimed_size = 16;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3613 # endif
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3614 if (claimed_size < 4096)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3615 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3616 /* fxg: rename log->log2 to supress gcc3 shadow warning */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3617 int log2 = 1;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3618
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3619 /* compute the log base two, more or less, then use it to compute
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3620 the block size needed. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3621 claimed_size--;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3622 /* It's big, it's heavy, it's wood! */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3623 while ((claimed_size /= 2) != 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3624 ++log2;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3625 claimed_size = 1;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3626 /* It's better than bad, it's good! */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3627 while (log2 > 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3628 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3629 claimed_size *= 2;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3630 log2--;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3631 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3632 /* We have to come up with some average about the amount of
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3633 blocks used. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3634 if ((Bytecount) (rand () & 4095) < claimed_size)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3635 claimed_size += 3 * sizeof (void *);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3636 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3637 else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3638 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3639 claimed_size += 4095;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3640 claimed_size &= ~4095;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3641 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3642 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3643
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3644 #else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3645
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3646 if (claimed_size < 16)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3647 claimed_size = 16;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3648 claimed_size += 2 * sizeof (void *);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3649
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3650 #endif /* system allocator */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3651
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3652 if (stats)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3653 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3654 stats->was_requested += orig_claimed_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3655 stats->malloc_overhead += claimed_size - orig_claimed_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3656 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3657 return claimed_size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3658 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3659
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3660 #ifndef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3661 static Bytecount
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3662 fixed_type_block_overhead (Bytecount size, Bytecount per_block)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3663 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3664 Bytecount overhead = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3665 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3666 while (size >= per_block)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3667 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3668 size -= per_block;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3669 overhead += storage_size - per_block;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3670 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3671 if (rand () % per_block < size)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3672 overhead += storage_size - per_block;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3673 return overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3674 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3675 #endif /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3676
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3677 Bytecount
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3678 lisp_object_storage_size (Lisp_Object obj, struct usage_stats *ustats)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3679 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3680 #ifndef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3681 const struct lrecord_implementation *imp =
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3682 XRECORD_LHEADER_IMPLEMENTATION (obj);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3683 #endif /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3684 Bytecount size = lisp_object_size (obj);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3685
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3686 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3687 return mc_alloced_storage_size (size, ustats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3688 #else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3689 if (imp->frob_block_p)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3690 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3691 Bytecount overhead =
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3692 /* #### Always using cons_block is incorrect but close; only
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3693 string_chars_block is significantly different in size, and
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3694 it won't ever be seen in this function */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3695 fixed_type_block_overhead (size, sizeof (struct cons_block));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3696 if (ustats)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3697 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3698 ustats->was_requested += size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3699 ustats->malloc_overhead += overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3700 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3701 return size + overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3702 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3703 else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3704 return malloced_storage_size (XPNTR (obj), size, ustats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3705 #endif
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3706 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3707
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3708
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3709 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3710 /* Allocation Statistics: Accumulate */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3711 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3712
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3713 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3714
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3715 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3716 init_lrecord_stats (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3717 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3718 xzero (lrecord_stats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3719 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3720
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3721 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3722 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3723 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3724 int type_index = h->type;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3725 if (!size)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3726 size = detagged_lisp_object_size (h);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3727
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3728 lrecord_stats[type_index].instances_in_use++;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3729 lrecord_stats[type_index].bytes_in_use += size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3730 lrecord_stats[type_index].bytes_in_use_including_overhead
5158
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3731 #ifdef MEMORY_USAGE_STATS
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3732 += mc_alloced_storage_size (size, 0);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3733 #else /* not MEMORY_USAGE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3734 += size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3735 #endif /* not MEMORY_USAGE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3736 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3737
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3738 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3739 dec_lrecord_stats (Bytecount size_including_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3740 const struct lrecord_header *h)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3741 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3742 int type_index = h->type;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3743 int size = detagged_lisp_object_size (h);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3744
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3745 lrecord_stats[type_index].instances_in_use--;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3746 lrecord_stats[type_index].bytes_in_use -= size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3747 lrecord_stats[type_index].bytes_in_use_including_overhead
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3748 -= size_including_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3749
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3750 DECREMENT_CONS_COUNTER (size);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3751 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3752
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3753 int
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3754 lrecord_stats_heap_size (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3755 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3756 int i;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3757 int size = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3758 for (i = 0; i < countof (lrecord_implementations_table); i++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3759 size += lrecord_stats[i].bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3760 return size;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3761 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3762
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3763 #else /* not NEW_GC */
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3764
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3765 static void
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3766 clear_lrecord_stats (void)
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3767 {
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3768 xzero (lrecord_stats);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3769 gc_count_num_short_string_in_use = 0;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3770 gc_count_string_total_size = 0;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3771 gc_count_short_string_total_size = 0;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3772 gc_count_long_string_storage_including_overhead = 0;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3773 }
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3774
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3775 /* Keep track of extra statistics for strings -- length of the string
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3776 characters for short and long strings, number of short and long strings. */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3777 static void
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3778 tick_string_stats (Lisp_String *p, int from_sweep)
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3779 {
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3780 Bytecount size = p->size_;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3781 gc_count_string_total_size += size;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3782 if (!BIG_STRING_SIZE_P (size))
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3783 {
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3784 gc_count_short_string_total_size += size;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3785 gc_count_num_short_string_in_use++;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3786 }
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3787 else
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3788 gc_count_long_string_storage_including_overhead +=
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3789 malloced_storage_size (p->data_, p->size_, NULL);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3790 /* During the sweep stage, we count the total number of strings in use.
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3791 This gets those not stored in pdump storage. For pdump storage, we
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3792 need to bump the number of strings in use so as to get an accurate
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3793 count of all strings in use (pdump or not). But don't do this when
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3794 called from the sweep stage, or we will double-count. */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3795 if (!from_sweep)
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3796 gc_count_num_string_in_use++;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3797 }
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3798
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3799 /* As objects are sweeped, we record statistics about their memory usage.
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3800 Currently, all lcrecords are processed this way as well as any frob-block
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3801 objects that were saved and restored as a result of the pdump process.
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3802 (See pdump_objects_unmark().) Other frob-block objects do NOT get their
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3803 statistics noted this way -- instead, as the frob blocks are swept,
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3804 COPY_INTO_LRECORD_STATS() is called, and notes statistics about the
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3805 frob blocks. */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3806
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3807 void
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3808 tick_lrecord_stats (const struct lrecord_header *h,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3809 enum lrecord_alloc_status status)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3810 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3811 int type_index = h->type;
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3812 Bytecount obj = wrap_pointer_1 (h);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3813 Bytecount sz = lisp_object_size (obj);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3814 Bytecount sz_with_overhead = lisp_object_storage_size (obj, NULL);
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3815 Bytecount overhead = sz_with_overhead - sz;
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3816
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3817 switch (status)
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3818 {
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3819 case ALLOC_IN_USE:
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3820 lrecord_stats[type_index].instances_in_use++;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3821 lrecord_stats[type_index].bytes_in_use += sz;
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3822 lrecord_stats[type_index].bytes_in_use_overhead += overhead;
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3823 if (STRINGP (obj))
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3824 tick_string_stats (XSTRING (obj), 0);
5158
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3825 #ifdef MEMORY_USAGE_STATS
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3826 {
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3827 struct generic_usage_stats stats;
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3828 if (HAS_OBJECT_METH_P (obj, memory_usage))
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3829 {
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3830 int i;
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3831 int total_stats = OBJECT_PROPERTY (obj, num_extra_memusage_stats);
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3832 xzero (stats);
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3833 OBJECT_METH (obj, memory_usage, (obj, &stats));
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3834 for (i = 0; i < total_stats; i++)
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3835 lrecord_stats[type_index].stats.othervals[i] +=
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3836 stats.othervals[i];
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3837 }
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3838 }
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
3839 #endif
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3840 break;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3841 case ALLOC_FREE:
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3842 lrecord_stats[type_index].instances_freed++;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3843 lrecord_stats[type_index].bytes_freed += sz;
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3844 lrecord_stats[type_index].bytes_freed_overhead += overhead;
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3845 break;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3846 case ALLOC_ON_FREE_LIST:
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3847 lrecord_stats[type_index].instances_on_free_list++;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3848 lrecord_stats[type_index].bytes_on_free_list += sz;
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3849 lrecord_stats[type_index].bytes_on_free_list_overhead += overhead;
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3850 break;
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3851 default:
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3852 ABORT ();
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3853 }
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3854 }
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3855
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3856 inline static void
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3857 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3858 {
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
3859 if (h->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3861 gc_checking_assert (!free_p);
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3862 tick_lrecord_stats (h, ALLOC_ON_FREE_LIST);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 else
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
3865 tick_lrecord_stats (h, free_p ? ALLOC_FREE : ALLOC_IN_USE);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 }
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
3867
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3868 #endif /* (not) NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3869
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3870 void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3871 finish_object_memory_usage_stats (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3872 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3873 /* Here we add up the aggregate values for each statistic, previously
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3874 computed during tick_lrecord_stats(), to get a single combined value
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3875 of non-Lisp memory usage for all objects of each type. We can't
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3876 do this if NEW_GC because nothing like tick_lrecord_stats() gets
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3877 called -- instead, statistics are computed when objects are allocated,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3878 which is too early to be calling the memory_usage() method. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3879 #if defined (MEMORY_USAGE_STATS) && !defined (NEW_GC)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3880 int i;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3881 for (i = 0; i < countof (lrecord_implementations_table); i++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3882 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3883 struct lrecord_implementation *imp = lrecord_implementations_table[i];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3884 if (imp && imp->num_extra_nonlisp_memusage_stats)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3885 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3886 int j;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3887 for (j = 0; j < imp->num_extra_nonlisp_memusage_stats; j++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3888 lrecord_stats[i].nonlisp_bytes_in_use +=
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3889 lrecord_stats[i].stats.othervals[j];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3890 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3891 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3892 #endif /* defined (MEMORY_USAGE_STATS) && !defined (NEW_GC) */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3893 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3894
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3895 #define COUNT_FROB_BLOCK_USAGE(type) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3896 EMACS_INT s = 0; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3897 EMACS_INT s_overhead = 0; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3898 struct type##_block *x = current_##type##_block; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3899 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3900 s_overhead = fixed_type_block_overhead (s, sizeof (struct type##_block)); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3901 DO_NOTHING
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3902
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3903 #define COPY_INTO_LRECORD_STATS(type) \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3904 do { \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3905 COUNT_FROB_BLOCK_USAGE (type); \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3906 lrecord_stats[lrecord_type_##type].bytes_in_use += s; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3907 lrecord_stats[lrecord_type_##type].bytes_in_use_overhead += \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3908 s_overhead; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3909 lrecord_stats[lrecord_type_##type].instances_on_free_list += \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3910 gc_count_num_##type##_freelist; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3911 lrecord_stats[lrecord_type_##type].instances_in_use += \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3912 gc_count_num_##type##_in_use; \
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3913 } while (0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3914
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3915
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3916 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3917 /* Allocation statistics: format nicely */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3918 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3919
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3920 static Lisp_Object
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3921 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3922 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3923 /* C doesn't have local functions (or closures, or GC, or readable syntax,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3924 or portable numeric datatypes, or bit-vectors, or characters, or
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3925 arrays, or exceptions, or ...) */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3926 return cons3 (intern (name), make_int (value), tail);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3927 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3928
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3929 /* Pluralize a lowercase English word stored in BUF, assuming BUF has
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3930 enough space to hold the extra letters (at most 2). */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3931 static void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3932 pluralize_word (Ascbyte *buf)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3933 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3934 Bytecount len = strlen (buf);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3935 int upper = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3936 Ascbyte d, e;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3937
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3938 if (len == 0 || len == 1)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3939 goto pluralize_apostrophe_s;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3940 e = buf[len - 1];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3941 d = buf[len - 2];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3942 upper = isupper (e);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3943 e = tolower (e);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3944 d = tolower (d);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3945 if (e == 'y')
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3946 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3947 switch (d)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3948 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3949 case 'a':
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3950 case 'e':
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3951 case 'i':
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3952 case 'o':
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3953 case 'u':
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3954 goto pluralize_s;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3955 default:
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3956 buf[len - 1] = (upper ? 'I' : 'i');
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3957 goto pluralize_es;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3958 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3959 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3960 else if (e == 's' || e == 'x' || (e == 'h' && (d == 's' || d == 'c')))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3961 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3962 pluralize_es:
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3963 buf[len++] = (upper ? 'E' : 'e');
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3964 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3965 pluralize_s:
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3966 buf[len++] = (upper ? 'S' : 's');
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3967 buf[len] = '\0';
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3968 return;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3969
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3970 pluralize_apostrophe_s:
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3971 buf[len++] = '\'';
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3972 goto pluralize_s;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3973 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3974
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3975 static void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3976 pluralize_and_append (Ascbyte *buf, const Ascbyte *name, const Ascbyte *suffix)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3977 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3978 strcpy (buf, name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3979 pluralize_word (buf);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3980 strcat (buf, suffix);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3981 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3982
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3983 static Lisp_Object
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3984 object_memory_usage_stats (int set_total_gc_usage)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3985 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3986 Lisp_Object pl = Qnil;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3987 int i;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3988 EMACS_INT tgu_val = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3989
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3990 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3991 for (i = 0; i < countof (lrecord_implementations_table); i++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3992 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3993 if (lrecord_stats[i].instances_in_use != 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3994 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3995 Ascbyte buf[255];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3996 const Ascbyte *name = lrecord_implementations_table[i]->name;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3997
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3998 if (lrecord_stats[i].bytes_in_use_including_overhead !=
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
3999 lrecord_stats[i].bytes_in_use)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4000 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4001 sprintf (buf, "%s-storage-including-overhead", name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4002 pl = gc_plist_hack (buf,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4003 lrecord_stats[i]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4004 .bytes_in_use_including_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4005 pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4006 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4007
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4008 sprintf (buf, "%s-storage", name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4009 pl = gc_plist_hack (buf,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4010 lrecord_stats[i].bytes_in_use,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4011 pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4012 tgu_val += lrecord_stats[i].bytes_in_use_including_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4013
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4014 pluralize_and_append (buf, name, "-used");
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4015 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4016 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4017 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4018
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4019 #else /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4020
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4021 for (i = 0; i < lrecord_type_count; i++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4022 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4023 if (lrecord_stats[i].bytes_in_use != 0
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4024 || lrecord_stats[i].bytes_freed != 0
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4025 || lrecord_stats[i].instances_on_free_list != 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4026 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4027 Ascbyte buf[255];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4028 const Ascbyte *name = lrecord_implementations_table[i]->name;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4029
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4030 sprintf (buf, "%s-storage-overhead", name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4031 pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use_overhead, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4032 tgu_val += lrecord_stats[i].bytes_in_use_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4033 sprintf (buf, "%s-storage", name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4034 pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4035 tgu_val += lrecord_stats[i].bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4036 #ifdef MEMORY_USAGE_STATS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4037 if (lrecord_stats[i].nonlisp_bytes_in_use)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4038 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4039 sprintf (buf, "%s-non-lisp-storage", name);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4040 pl = gc_plist_hack (buf, lrecord_stats[i].nonlisp_bytes_in_use,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4041 pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4042 tgu_val += lrecord_stats[i].nonlisp_bytes_in_use;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4043 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4044 #endif /* MEMORY_USAGE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4045 pluralize_and_append (buf, name, "-freed");
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4046 if (lrecord_stats[i].instances_freed != 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4047 pl = gc_plist_hack (buf, lrecord_stats[i].instances_freed, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4048 pluralize_and_append (buf, name, "-on-free-list");
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4049 if (lrecord_stats[i].instances_on_free_list != 0)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4050 pl = gc_plist_hack (buf, lrecord_stats[i].instances_on_free_list,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4051 pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4052 pluralize_and_append (buf, name, "-used");
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4053 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4054 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4055 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4056
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4057 pl = gc_plist_hack ("long-string-chars-storage-overhead",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4058 gc_count_long_string_storage_including_overhead -
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4059 (gc_count_string_total_size
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4060 - gc_count_short_string_total_size), pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4061 pl = gc_plist_hack ("long-string-chars-storage",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4062 gc_count_string_total_size
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4063 - gc_count_short_string_total_size, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4064 do
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4065 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4066 COUNT_FROB_BLOCK_USAGE (string_chars);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4067 tgu_val += s + s_overhead;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4068 pl = gc_plist_hack ("short-string-chars-storage-overhead", s_overhead, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4069 pl = gc_plist_hack ("short-string-chars-storage", s, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4070 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4071 while (0);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4072
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4073 pl = gc_plist_hack ("long-strings-total-length",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4074 gc_count_string_total_size
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4075 - gc_count_short_string_total_size, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4076 pl = gc_plist_hack ("short-strings-total-length",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4077 gc_count_short_string_total_size, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4078 pl = gc_plist_hack ("long-strings-used",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4079 gc_count_num_string_in_use
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4080 - gc_count_num_short_string_in_use, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4081 pl = gc_plist_hack ("short-strings-used",
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4082 gc_count_num_short_string_in_use, pl);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4083
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4084 #endif /* NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4085
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4086 if (set_total_gc_usage)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4087 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4088 total_gc_usage = tgu_val;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4089 total_gc_usage_set = 1;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4090 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4091
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4092 return pl;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4093 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4094
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4095 static Lisp_Object
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4096 garbage_collection_statistics (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4097 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4098 /* The things we do for backwards-compatibility */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4099 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4100 return
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4101 list6
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4102 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4103 make_int (lrecord_stats[lrecord_type_cons]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4104 .bytes_in_use_including_overhead)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4105 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4106 make_int (lrecord_stats[lrecord_type_symbol]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4107 .bytes_in_use_including_overhead)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4108 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4109 make_int (lrecord_stats[lrecord_type_marker]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4110 .bytes_in_use_including_overhead)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4111 make_int (lrecord_stats[lrecord_type_string]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4112 .bytes_in_use_including_overhead),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4113 make_int (lrecord_stats[lrecord_type_vector]
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4114 .bytes_in_use_including_overhead),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4115 object_memory_usage_stats (1));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4116 #else /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4117 return
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4118 list6 (Fcons (make_int (gc_count_num_cons_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4119 make_int (gc_count_num_cons_freelist)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4120 Fcons (make_int (gc_count_num_symbol_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4121 make_int (gc_count_num_symbol_freelist)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4122 Fcons (make_int (gc_count_num_marker_in_use),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4123 make_int (gc_count_num_marker_freelist)),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4124 make_int (gc_count_string_total_size),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4125 make_int (lrecord_stats[lrecord_type_vector].bytes_in_use +
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4126 lrecord_stats[lrecord_type_vector].bytes_freed +
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4127 lrecord_stats[lrecord_type_vector].bytes_on_free_list),
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4128 object_memory_usage_stats (1));
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4129 #endif /* not NEW_GC */
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4130 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4131
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4132 DEFUN ("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0, 0, /*
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4133 Return statistics about memory usage of Lisp objects.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4134 */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4135 ())
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4136 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4137 return object_memory_usage_stats (0);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4138 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4139
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4140 #endif /* ALLOC_TYPE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4141
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4142 #ifdef MEMORY_USAGE_STATS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4143
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4144 DEFUN ("object-memory-usage", Fobject_memory_usage, 1, 1, 0, /*
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4145 Return stats about the memory usage of OBJECT.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4146 The values returned are in the form of an alist of usage types and byte
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4147 counts. The byte counts attempt to encompass all the memory used
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4148 by the object (separate from the memory logically associated with any
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4149 other object), including internal structures and any malloc()
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4150 overhead associated with them. In practice, the byte counts are
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4151 underestimated because certain memory usage is very hard to determine
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4152 \(e.g. the amount of memory used inside the Xt library or inside the
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4153 X server).
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4154
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4155 Multiple slices of the total memory usage may be returned, separated
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4156 by a nil. Each slice represents a particular view of the memory, a
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4157 particular way of partitioning it into groups. Within a slice, there
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4158 is no overlap between the groups of memory, and each slice collectively
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4159 represents all the memory concerned. The rightmost slice typically
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4160 represents the total memory used plus malloc and dynarr overhead.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4161
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4162 Slices describing other Lisp objects logically associated with the
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4163 object may be included, separated from other slices by `t' and from
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4164 each other by nil if there is more than one.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4165
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4166 #### We have to figure out how to handle the memory used by the object
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4167 itself vs. the memory used by substructures. Probably the memory_usage
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4168 method should return info only about substructures and related Lisp
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4169 objects, since the caller can always find and all info about the object
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4170 itself.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4171 */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4172 (object))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4173 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4174 struct generic_usage_stats gustats;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4175 struct usage_stats object_stats;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4176 int i;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4177 Lisp_Object val = Qnil;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4178 Lisp_Object stats_list = OBJECT_PROPERTY (object, memusage_stats_list);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4179
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4180 xzero (object_stats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4181 lisp_object_storage_size (object, &object_stats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4182
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4183 val = acons (Qobject_actually_requested,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4184 make_int (object_stats.was_requested), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4185 val = acons (Qobject_malloc_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4186 make_int (object_stats.malloc_overhead), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4187 assert (!object_stats.dynarr_overhead);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4188 assert (!object_stats.gap_overhead);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4189
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4190 if (!NILP (stats_list))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4191 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4192 xzero (gustats);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4193 MAYBE_OBJECT_METH (object, memory_usage, (object, &gustats));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4194
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4195 val = Fcons (Qt, val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4196 val = acons (Qother_memory_actually_requested,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4197 make_int (gustats.u.was_requested), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4198 val = acons (Qother_memory_malloc_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4199 make_int (gustats.u.malloc_overhead), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4200 if (gustats.u.dynarr_overhead)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4201 val = acons (Qother_memory_dynarr_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4202 make_int (gustats.u.dynarr_overhead), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4203 if (gustats.u.gap_overhead)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4204 val = acons (Qother_memory_gap_overhead,
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4205 make_int (gustats.u.gap_overhead), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4206 val = Fcons (Qnil, val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4207
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4208 i = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4209 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4210 LIST_LOOP_2 (item, stats_list)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4211 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4212 if (NILP (item) || EQ (item, Qt))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4213 val = Fcons (item, val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4214 else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4215 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4216 val = acons (item, make_int (gustats.othervals[i]), val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4217 i++;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4218 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4219 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4220 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4221 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4222
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4223 return Fnreverse (val);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4224 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4225
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4226 #endif /* MEMORY_USAGE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4227
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4228 #ifdef ALLOC_TYPE_STATS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4229
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4230 DEFUN ("total-object-memory-usage", Ftotal_object_memory_usage, 0, 0, 0, /*
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4231 Return total number of bytes used for object storage in XEmacs.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4232 This may be helpful in debugging XEmacs's memory usage.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4233 See also `consing-since-gc' and `object-memory-usage-stats'.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4234 */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4235 ())
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4236 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4237 return make_int (total_gc_usage + consing_since_gc);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4238 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4239
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4240 #endif /* ALLOC_TYPE_STATS */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4241
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4242
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4243 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4244 /* Allocation statistics: Initialization */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4245 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4246 #ifdef MEMORY_USAGE_STATS
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4247
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4248 /* Compute the number of extra memory-usage statistics associated with an
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4249 object. We can't compute this at the time INIT_LISP_OBJECT() is called
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4250 because the value of the `memusage_stats_list' property is generally
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4251 set afterwards. So we compute the values for all types of objects
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4252 after all objects have been initialized. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4253
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4254 static void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4255 compute_memusage_stats_length (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4256 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4257 int i;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4258
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4259 for (i = 0; i < countof (lrecord_implementations_table); i++)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4260 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4261 int len = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4262 int nonlisp_len = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4263 int seen_break = 0;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4264
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4265 struct lrecord_implementation *imp = lrecord_implementations_table[i];
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4266
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4267 if (!imp)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4268 continue;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4269 /* For some of the early objects, Qnil was not yet initialized at
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4270 the time of object initialization, so it came up as Qnull_pointer.
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4271 Fix that now. */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4272 if (EQ (imp->memusage_stats_list, Qnull_pointer))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4273 imp->memusage_stats_list = Qnil;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4274 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4275 LIST_LOOP_2 (item, imp->memusage_stats_list)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4276 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4277 if (!NILP (item) && !EQ (item, Qt))
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4278 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4279 len++;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4280 if (!seen_break)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4281 nonlisp_len++;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4282 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4283 else
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4284 seen_break++;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4285 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4286 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4287
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4288 imp->num_extra_memusage_stats = len;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4289 imp->num_extra_nonlisp_memusage_stats = nonlisp_len;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4290 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4291 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4292
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
4293 #endif /* MEMORY_USAGE_STATS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4295
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
4296 /************************************************************************/
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
4297 /* Garbage Collection -- Sweep/Compact */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
4298 /************************************************************************/
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
4299
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4300 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4301 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 static void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4303 sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used)
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4304 {
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4305 struct old_lcrecord_header *header;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4307 /* int total_size = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4308
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4309 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4310 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 other object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 for (header = *prev; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4322
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4323 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4324
5142
f965e31a35f0 reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents: 5127
diff changeset
4325 if (! MARKED_RECORD_HEADER_P (h) && !h->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 if (LHEADER_IMPLEMENTATION (h)->finalizer)
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
4328 LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4329 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 for (header = *prev; header; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4335 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4337 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4341 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4348 struct old_lcrecord_header *next = header->next;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 /* used to call finalizer right here. */
4976
16112448d484 Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents: 4969
diff changeset
4352 xfree (header);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 /* *total = total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4364
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4365 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4367 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4368 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4371 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 ) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4382 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4390 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4398 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 gc_count_num_##typename##_freelist = num_free; \
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4407 COPY_INTO_LRECORD_STATS (typename); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4412 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4413 do { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4414 struct typename##_block *SFTB_current; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4415 struct typename##_block **SFTB_prev; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4416 int SFTB_limit; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4417 int num_free = 0, num_used = 0; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4418 \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4419 typename##_free_list = 0; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4420 \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4421 for (SFTB_prev = &current_##typename##_block, \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4422 SFTB_current = current_##typename##_block, \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4423 SFTB_limit = current_##typename##_block_index; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4424 SFTB_current; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4425 ) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4426 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4427 int SFTB_iii; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4428 int SFTB_empty = 1; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4429 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4430 \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4431 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4432 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4433 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4434 \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4435 if (LRECORD_FREE_P (SFTB_victim)) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4436 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4437 num_free++; \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4438 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4439 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4440 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4441 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4442 SFTB_empty = 0; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4443 num_used++; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4444 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4445 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4446 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4447 num_free++; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4448 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4449 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4450 else \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4451 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4452 SFTB_empty = 0; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4453 num_used++; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4454 UNMARK_##typename (SFTB_victim); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4455 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4456 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4457 if (!SFTB_empty) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4458 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4459 SFTB_prev = &(SFTB_current->prev); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4460 SFTB_current = SFTB_current->prev; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4461 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4462 else if (SFTB_current == current_##typename##_block \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4463 && !SFTB_current->prev) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4464 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4465 /* No real point in freeing sole allocation block */ \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4466 break; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4467 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4468 else \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4469 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4470 struct typename##_block *SFTB_victim_block = SFTB_current; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4471 if (SFTB_victim_block == current_##typename##_block) \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4472 current_##typename##_block_index \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4473 = countof (current_##typename##_block->block); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4474 SFTB_current = SFTB_current->prev; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4475 { \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4476 *SFTB_prev = SFTB_current; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4477 xfree (SFTB_victim_block); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4478 /* Restore free list to what it was before victim was swept */ \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4479 typename##_free_list = SFTB_old_free_list; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4480 num_free -= SFTB_limit; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4481 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4482 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4483 SFTB_limit = countof (current_##typename##_block->block); \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4484 } \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4485 \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4486 gc_count_num_##typename##_in_use = num_used; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4487 gc_count_num_##typename##_freelist = num_free; \
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4488 COPY_INTO_LRECORD_STATS (typename); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4489 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4490
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4491 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4492
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4493 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4494 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4495
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4496 #endif /* not NEW_GC */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4497
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4498
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4499 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4500 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4501 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4502 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4503 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4504 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4505
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4506 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4507 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4508 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4509
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4510 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4511 void
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4512 free_cons (Lisp_Object cons)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4513 {
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4514 #ifndef NEW_GC /* to avoid compiler warning */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4515 Lisp_Cons *ptr = XCONS (cons);
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4516 #endif /* not NEW_GC */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4517
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4518 #ifdef ERROR_CHECK_GC
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4519 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4520 Lisp_Cons *ptr = XCONS (cons);
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4521 #endif /* NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4522 /* If the CAR is not an int, then it will be a pointer, which will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4523 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4524 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4525 a chain pointer to the next cons on the list, which has cleverly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4526 had all its 0's and 1's inverted. This allows for a quick
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4527 check to make sure we're not freeing something already freed.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4528
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4529 NOTE: This check may not be necessary. Freeing an object sets its
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4530 type to lrecord_type_free, which will trip up the XCONS() above -- as
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4531 well as a check in FREE_FIXED_TYPE(). */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4532 if (POINTER_TYPE_P (XTYPE (cons_car (ptr))))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4533 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4534 #endif /* ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4535
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4536 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, cons, Lisp_Cons, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4537 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4539 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4540 created all the cons cells that make up this list and that there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4541 are no pointers to any of these cons cells anywhere else. If there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4542 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4543
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4544 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4545 free_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4546 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4547 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4548
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4549 for (rest = list; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4550 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4551 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4552 free_cons (rest);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4553 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4554 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4556 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4557 created all the cons cells that make up this alist and that there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4558 are no pointers to any of these cons cells anywhere else. If there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4559 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4560
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4561 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4562 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4563 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4564 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4565
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4566 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4567 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4568 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4569 free_cons (XCAR (rest));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4570 free_cons (rest);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4571 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4572 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4573
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4574 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4575 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4576 sweep_compiled_functions (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4577 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4578 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
945
7924b28c57a4 [xemacs-hg @ 2002-08-01 08:38:32 by michaels]
michaels
parents: 943
diff changeset
4579 #define ADDITIONAL_FREE_compiled_function(ptr) \
4976
16112448d484 Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents: 4969
diff changeset
4580 if (ptr->args_in_array) xfree (ptr->args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4581
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4582 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4583 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4585 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4586 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4587 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4588 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4589 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4590
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4591 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4592 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4593
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4594 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4595 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4596 sweep_bignums (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4597 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4598 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4599 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4600
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4601 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4602 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4603 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4604
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4605 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4606 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4607 sweep_ratios (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4608 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4609 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4610 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4611
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4612 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4613 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4614 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4615
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4616 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4617 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4618 sweep_bigfloats (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4619 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4620 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4621 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4622
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4623 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4624 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4625 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4626
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4627 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4628 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4629 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4630 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4631 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4632
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4633 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4634 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4636 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4637 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4638 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4639 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4640 #define ADDITIONAL_FREE_extent(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4641
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4642 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4643 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4645 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4646 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4647 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4648 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4649 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4650
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4651 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4652 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4653 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4654
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4655 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4656
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4657 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4658 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4659 sweep_key_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4660 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4661 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4662 #define ADDITIONAL_FREE_key_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4663
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4664 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4665 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4666 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4667
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4668 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4669 free_key_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4670 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4671 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, key_data, Lisp_Key_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4672 XKEY_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4673 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4674
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4675 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4676 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4677 sweep_button_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4678 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4679 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4680 #define ADDITIONAL_FREE_button_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4681
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4682 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4683 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4684 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4685
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4686 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4687 free_button_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4688 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4689 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, button_data, Lisp_Button_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4690 XBUTTON_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4691 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4692
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4693 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4694 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4695 sweep_motion_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4696 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4697 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4698 #define ADDITIONAL_FREE_motion_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4699
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4700 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4701 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4702 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4703
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4704 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4705 free_motion_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4706 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4707 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, motion_data, Lisp_Motion_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4708 XMOTION_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4709 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4710
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4711 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4712 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4713 sweep_process_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4714 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4715 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4716 #define ADDITIONAL_FREE_process_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4717
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4718 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4719 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4720 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4721
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4722 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4723 free_process_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4724 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4725 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, process_data, Lisp_Process_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4726 XPROCESS_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4727 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4728
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4729 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4730 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4731 sweep_timeout_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4732 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4733 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4734 #define ADDITIONAL_FREE_timeout_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4735
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4736 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4737 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4738 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4739
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4740 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4741 free_timeout_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4742 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4743 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, timeout_data, Lisp_Timeout_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4744 XTIMEOUT_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4745 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4746
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4747 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4748 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4749 sweep_magic_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4750 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4751 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4752 #define ADDITIONAL_FREE_magic_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4753
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4754 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4755 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4756 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4757
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4758 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4759 free_magic_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4760 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4761 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_data, Lisp_Magic_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4762 XMAGIC_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4763 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4764
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4765 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4766 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4767 sweep_magic_eval_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4768 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4769 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4770 #define ADDITIONAL_FREE_magic_eval_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4771
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4772 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4773 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4774 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4775
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4776 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4777 free_magic_eval_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4778 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4779 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, magic_eval_data, Lisp_Magic_Eval_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4780 XMAGIC_EVAL_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4781 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4782
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4783 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4784 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4785 sweep_eval_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4786 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4787 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4788 #define ADDITIONAL_FREE_eval_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4789
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4790 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4791 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4792 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4793
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4794 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4795 free_eval_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4796 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4797 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, eval_data, Lisp_Eval_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4798 XEVAL_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4799 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4800
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4801 #ifndef NEW_GC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4802 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4803 sweep_misc_user_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4804 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4805 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4806 #define ADDITIONAL_FREE_misc_user_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4807
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4808 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4809 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4810 #endif /* not NEW_GC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4811
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4812 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4813 free_misc_user_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4814 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4815 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, misc_user_data, Lisp_Misc_User_Data,
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4816 XMISC_USER_DATA (ptr));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4817 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4818
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4819 #endif /* EVENT_DATA_AS_OBJECTS */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4820
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4821 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4822 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4823 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4824 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4825 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4826 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4827 do { Lisp_Object tem; \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4828 tem = wrap_marker (ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4829 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4830 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4831
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4832 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4833 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4834 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4835
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4838 free_marker (Lisp_Object ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4839 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
4840 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (ptr, marker, Lisp_Marker, XMARKER (ptr));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4841 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4844 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4845
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4846 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4847 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4848 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4849 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4851 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4852 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4853 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4854 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4855 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4856 while (pos < sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4858 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4859 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4860 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4861 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4862 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4863
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4864 /* If the string_chars struct is marked as free (i.e. the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4865 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4866 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4867
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4868 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4869 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4870 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4871 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4872 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4873 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4875 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4876 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4877 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4878
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4879 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4880 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4881
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4882 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4883 assert (XSTRING_DATA (string) == s_chars->chars);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4884 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4886 assert (pos == sb->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4887 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4888 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4889
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4890 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4891
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
4892 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4893 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4894 free any empty string_chars_block we see. */
5016
2ade80e8c640 enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents: 4976
diff changeset
4895 static void
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4896 compact_string_chars (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4897 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4898 struct string_chars_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4899 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4900 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4902 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4903 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4904 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4905 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4906 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4907 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4908 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4909 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4910 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4911 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4912 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4913 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4914 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4915
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4916 /* If the string_chars struct is marked as free (i.e. the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4917 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4918 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4919 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4920 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4921 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4922 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4923 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4924
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4925 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4926 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4927 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4928 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4929 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4930 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4931
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4932 string = from_s_chars->string;
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4933 gc_checking_assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4934
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4935 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4936 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4937
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4938 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4939
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4940 /* Just skip it if it isn't marked. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4941 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4942 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4943 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4944 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4945 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4947 /* If it won't fit in what's left of TO_SB, close TO_SB out
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4948 and go on to the next string_chars_block. We know that TO_SB
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4949 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4950 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4951 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4952 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4953 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4954 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4955 to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4956 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4958 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4959 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4960 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4961
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4962 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4963 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4964 memmove (to_s_chars, from_s_chars, fullsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4965
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4966 /* Relocate FROM_S_CHARS's reference */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
4967 set_lispstringp_data (string, &(to_s_chars->chars[0]));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4968
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4969 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4970 to_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4971 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4972 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4973
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4974 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4975 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4976 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4977 struct string_chars_block *victim;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4979 for (victim = to_sb->next; victim; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4980 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4981 struct string_chars_block *next = victim->next;
4976
16112448d484 Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents: 4969
diff changeset
4982 xfree (victim);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4983 victim = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4984 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4985
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4986 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4987 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4988 current_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4989 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4990 }
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
4991 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4992
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
4993 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4994 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4995 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4996
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4997 static void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4998 debug_string_purity_print (Lisp_Object p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4999 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5000 Charcount i;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
5001 Charcount s = string_char_length (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5002 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5003 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5004 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
5005 Ichar ch = string_ichar (p, i);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5006 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5007 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5008 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5009 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5010 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5011 stderr_out ("%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5012 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5013 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5014 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5015 #endif /* 1 */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5016 #endif /* not NEW_GC */
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5017
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5018 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5019 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5020 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5021 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5022 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5023
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5024 #define UNMARK_string(ptr) do { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5025 Lisp_String *p = (ptr); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5026 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5027 tick_string_stats (p, 1); \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5028 if (debug) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5029 debug_string_purity_print (wrap_string (p)); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
5030 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
5031 #define ADDITIONAL_FREE_string(ptr) do { \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5032 Bytecount size = ptr->size_; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
5033 if (BIG_STRING_SIZE_P (size)) \
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
5034 xfree (ptr->data_); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
5035 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
5036
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5037 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5038 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5039 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5040
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5041 #ifndef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5042 void
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5043 gc_sweep_1 (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5044 {
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
5045 /* Reset all statistics to 0. They will be incremented when
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
5046 sweeping lcrecords, frob-block lrecords and dumped objects. */
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5047 clear_lrecord_stats ();
5059
c8f90d61dcf3 fix memory usage stats to include pdumped objects
Ben Wing <ben@xemacs.org>
parents: 5058
diff changeset
5048
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5049 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5050 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5051 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5052 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5053 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5054 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5055 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5056 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5057 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5058
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5059 compact_string_chars ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5061 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5062 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5063 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5064 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5065 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5066 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5067 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5068 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5069 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5070 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5072 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5073 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5074 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5075
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5076 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5077 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5078
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5079 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5080 sweep_compiled_functions ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5081
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5082 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5083 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5084
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5085 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5086 /* Put all unmarked bignums on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5087 sweep_bignums ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5088 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5089
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5090 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5091 /* Put all unmarked ratios on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5092 sweep_ratios ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5093 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5094
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5095 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5096 /* Put all unmarked bigfloats on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5097 sweep_bigfloats ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5098 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5099
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5100 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5101 sweep_symbols ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5103 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5104 sweep_extents ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5106 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5107 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5108 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5110 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5111
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5112 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5113 sweep_key_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5114 sweep_button_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5115 sweep_motion_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5116 sweep_process_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5117 sweep_timeout_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5118 sweep_magic_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5119 sweep_magic_eval_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5120 sweep_eval_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5121 sweep_misc_user_data ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5122 #endif /* EVENT_DATA_AS_OBJECTS */
5158
9e0b43d3095c more cleanups to object-memory-usage stuff
Ben Wing <ben@xemacs.org>
parents: 5157
diff changeset
5123
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5124 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5125 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5126 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5127 }
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5128 #endif /* not NEW_GC */
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5129
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5130
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5131 /************************************************************************/
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5132 /* "Disksave Finalization" -- Preparing for Dumping */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5133 /************************************************************************/
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5134
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5135 static void
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5136 disksave_object_finalization_1 (void)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5137 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5138 #ifdef NEW_GC
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5139 mc_finalize_for_disksave ();
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5140 #else /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5141 struct old_lcrecord_header *header;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5142
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5143 for (header = all_lcrecords; header; header = header->next)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5144 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5145 struct lrecord_header *objh = &header->lheader;
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5146 const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh);
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5147 #if 0 /* possibly useful for debugging */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5148 if (!RECORD_DUMPABLE (objh) && !objh->free)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5149 {
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5150 stderr_out ("Disksaving a non-dumpable object: ");
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5151 debug_print (wrap_pointer_1 (header));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5152 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5153 #endif
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5154 if (imp->disksave && !objh->free)
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5155 (imp->disksave) (wrap_pointer_1 (header));
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5156 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5157 #endif /* not NEW_GC */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5158 }
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5159
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5160 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5161 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5162 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5163 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5164 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5165 To make it easier to tell when this has happened with strings(1) we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5166 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5167 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5168 But first we set some notable variables to nil and do one more GC,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5169 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5170 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5171
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5172 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5173 Vprocess_environment = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5174 env_initted = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5175 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5176 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5177 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5178 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5179 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5180 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5181 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5182 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5183 Flocate_file_clear_hashing (Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5184 uncache_home_directory ();
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 771
diff changeset
5185 zero_out_command_line_status_vars ();
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
5186 clear_default_devices ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5188 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5189 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5190 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5191 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5192 Vshell_file_name = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5193
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5194 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5195 gc_full ();
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5196 #else /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5197 garbage_collect_1 ();
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5198 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5199
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5200 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5201 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5202
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5203 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5204 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5205 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5207 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5208 for (scb = first_string_chars_block; scb; scb = scb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5209 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5210 int count = sizeof (scb->string_chars) - scb->pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5211
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5212 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5213 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5214 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5215 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5216 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5217 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5218 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5219 }
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5220 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5222 /* There, that ought to be enough... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5223
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5224 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5225
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5226
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5227 /************************************************************************/
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5228 /* Lisp interface onto garbage collection */
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5229 /************************************************************************/
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5230
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5231 /* Debugging aids. */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5232
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5233 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5234 Reclaim storage for Lisp objects no longer needed.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5235 Return info on amount of space in use:
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5236 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5237 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5238 PLIST)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5239 where `PLIST' is a list of alternating keyword/value pairs providing
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5240 more detailed information.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5241 Garbage collection happens automatically if you cons more than
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5242 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5243 */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5244 ())
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5245 {
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5246 /* Record total usage for purposes of determining next GC */
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5247 #ifdef NEW_GC
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5248 gc_full ();
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5249 #else /* not NEW_GC */
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5250 garbage_collect_1 ();
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5251 #endif /* not NEW_GC */
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5252
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5253 /* This will get set to 1, and total_gc_usage computed, as part of the
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5254 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5255 total_gc_usage_set = 0;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5256 #ifdef ALLOC_TYPE_STATS
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5257 return garbage_collection_statistics ();
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5258 #else
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5259 return Qnil;
5167
e374ea766cc1 clean up, rearrange allocation statistics code
Ben Wing <ben@xemacs.org>
parents: 5160
diff changeset
5260 #endif
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5261 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5262
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5263 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5264 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5265 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5266 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5268 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5269 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5270 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5271 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5272 return make_int (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5273 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5274
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5275 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5276 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5277 Return the address of the last byte XEmacs has allocated, divided by 1024.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5278 This may be helpful in debugging XEmacs's memory usage.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5279 The value is divided by 1024 to make sure it will fit in a lisp integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5280 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5281 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5282 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5283 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5284 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5285 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5286
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5287 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /*
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5288 Return the total number of bytes used by the data segment in XEmacs.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5289 This may be helpful in debugging XEmacs's memory usage.
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5290 NOTE: This may or may not be accurate! It is hard to determine this
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5291 value in a system-independent fashion. On Windows, for example, the
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5292 returned number tends to be much greater than reality.
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5293 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5294 ())
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5295 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5296 return make_int (total_data_usage ());
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5297 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5298
4803
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5299 #ifdef USE_VALGRIND
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5300 DEFUN ("valgrind-leak-check", Fvalgrind_leak_check, 0, 0, "", /*
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5301 Ask valgrind to perform a memory leak check.
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5302 The results of the leak check are sent to stderr.
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5303 */
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5304 ())
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5305 {
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5306 VALGRIND_DO_LEAK_CHECK;
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5307 return Qnil;
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5308 }
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5309
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5310 DEFUN ("valgrind-quick-leak-check", Fvalgrind_quick_leak_check, 0, 0, "", /*
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5311 Ask valgrind to perform a quick memory leak check.
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5312 This just prints a summary of leaked memory, rather than all the details.
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5313 The results of the leak check are sent to stderr.
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5314 */
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5315 ())
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5316 {
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5317 VALGRIND_DO_QUICK_LEAK_CHECK;
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5318 return Qnil;
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5319 }
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5320 #endif /* USE_VALGRIND */
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5321
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5322
5160
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5323 /************************************************************************/
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5324 /* Initialization */
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5325 /************************************************************************/
ab9ee10a53e4 fix various problems with allocation statistics, track overhead properly
Ben Wing <ben@xemacs.org>
parents: 5159
diff changeset
5326
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5327 /* Initialization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5328 static void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5329 common_init_alloc_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5330 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5331 #ifndef Qzero
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5332 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5333 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5334
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5335 #ifndef Qnull_pointer
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5336 /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5337 so the following is actually a no-op. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5338 Qnull_pointer = wrap_pointer_1 (0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5339 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5340
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5341 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5342 breathing_space = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5343 all_lcrecords = 0;
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5344 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5345 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5346 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5347 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5348 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5349 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5350 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5351 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5352 #endif
3092
141c2920ea48 [xemacs-hg @ 2005-11-25 01:41:31 by crestani]
crestani
parents: 3063
diff changeset
5353 #ifndef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5354 init_string_chars_alloc ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5355 init_string_alloc ();
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5356 /* #### Is it intentional that this is called twice? --ben */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5357 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5358 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5359 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5360 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5361 init_float_alloc ();
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5362 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5363 init_bignum_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5364 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5365 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5366 init_ratio_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5367 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5368 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5369 init_bigfloat_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5370 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5371 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5372 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5373 init_event_alloc ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5374 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5375 init_key_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5376 init_button_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5377 init_motion_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5378 init_process_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5379 init_timeout_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5380 init_magic_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5381 init_magic_eval_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5382 init_eval_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5383 init_misc_user_data_alloc ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5384 #endif /* EVENT_DATA_AS_OBJECTS */
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5385 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5387 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5388
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5389 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5390 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5391 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5392 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5393 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5394 if (staticpro_nodump_names)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5395 Dynarr_free (staticpro_nodump_names);
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5396 staticpro_nodump_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5397 const Ascbyte *);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5398 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5399 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5400
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5401 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5402 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5403 Dynarr_resize (mcpros, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5404 dump_add_root_block_ptr (&mcpros, &mcpros_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5405 #ifdef DEBUG_XEMACS
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5406 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5407 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5408 dump_add_root_block_ptr (&mcpro_names,
4964
1f509f82c8c9 fix compile error
Ben Wing <ben@xemacs.org>
parents: 4962
diff changeset
5409 &const_Ascbyte_ptr_dynarr_description);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5410 #endif
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5411 #endif /* NEW_GC */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5412
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5413 consing_since_gc = 0;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5414 need_to_check_c_alloca = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5415 funcall_allocation_flag = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5416 funcall_alloca_count = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5417
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5418 #ifndef NEW_GC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5419 debug_string_purity = 0;
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5420 #endif /* not NEW_GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5421
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
5422 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5423 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5424 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5425 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5426 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5427 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5428 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5429 3333632;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5430 ERROR_ME_DEBUG_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5431 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
5432 8675309;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
5433 #endif /* ERROR_CHECK_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5434 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5435
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5436 #ifndef NEW_GC
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5437 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5438 init_lcrecord_lists (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5439 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5440 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5441
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5442 for (i = 0; i < countof (lrecord_implementations_table); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5443 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5444 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5445 staticpro_nodump (&all_lcrecord_lists[i]);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5446 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5447 }
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5448 #endif /* not NEW_GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5449
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5450 void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5451 init_alloc_early (void)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5452 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5453 #if defined (__cplusplus) && defined (ERROR_CHECK_GC)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5454 static struct gcpro initial_gcpro;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5455
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5456 initial_gcpro.next = 0;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5457 initial_gcpro.var = &Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5458 initial_gcpro.nvars = 1;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5459 gcprolist = &initial_gcpro;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5460 #else
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5461 gcprolist = 0;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5462 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5463 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5464
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5465 static void
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5466 reinit_alloc_objects_early (void)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5467 {
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5468 OBJECT_HAS_METHOD (string, getprop);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5469 OBJECT_HAS_METHOD (string, putprop);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5470 OBJECT_HAS_METHOD (string, remprop);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5471 OBJECT_HAS_METHOD (string, plist);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5472 }
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5473
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5474 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5475 reinit_alloc_early (void)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5476 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5477 common_init_alloc_early ();
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5478 #ifndef NEW_GC
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5479 init_lcrecord_lists ();
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5480 #endif /* not NEW_GC */
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5481 reinit_alloc_objects_early ();
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5482 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5483
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5484 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5485 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5486 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5487 common_init_alloc_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5488
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5489 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5490 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5491 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5492 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5493 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5494
5146
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
5495 dump_add_opaque (lrecord_uid_counter, sizeof (lrecord_uid_counter));
88bd4f3ef8e4 make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents: 5142
diff changeset
5496
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5497 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5498 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5499 dump_add_root_block_ptr (&staticpros, &staticpros_description);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5500 #ifdef DEBUG_XEMACS
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5501 staticpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5502 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5503 dump_add_root_block_ptr (&staticpro_names,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5504 &const_Ascbyte_ptr_dynarr_description);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5505 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5506
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5507 #ifdef NEW_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5508 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5509 Dynarr_resize (mcpros, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5510 dump_add_root_block_ptr (&mcpros, &mcpros_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5511 #ifdef DEBUG_XEMACS
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5512 mcpro_names = Dynarr_new2 (const_Ascbyte_ptr_dynarr, const Ascbyte *);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5513 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5514 dump_add_root_block_ptr (&mcpro_names,
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4938
diff changeset
5515 &const_Ascbyte_ptr_dynarr_description);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5516 #endif
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5517 #else /* not NEW_GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5518 init_lcrecord_lists ();
3263
d674024a8674 [xemacs-hg @ 2006-02-27 16:29:00 by crestani]
crestani
parents: 3176
diff changeset
5519 #endif /* not NEW_GC */
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5520
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5521 INIT_LISP_OBJECT (cons);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5522 INIT_LISP_OBJECT (vector);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5523 INIT_LISP_OBJECT (string);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5524
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5525 #ifdef NEW_GC
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5526 INIT_LISP_OBJECT (string_indirect_data);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5527 INIT_LISP_OBJECT (string_direct_data);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5528 #endif /* NEW_GC */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5529 #ifndef NEW_GC
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5530 INIT_LISP_OBJECT (lcrecord_list);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5531 INIT_LISP_OBJECT (free);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5532 #endif /* not NEW_GC */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5533
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5534 reinit_alloc_objects_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5535 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5536
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5537 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5538 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5539 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5540 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5541
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5542 #ifdef MEMORY_USAGE_STATS
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5543 DEFSYMBOL (Qobject_actually_requested);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5544 DEFSYMBOL (Qobject_malloc_overhead);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5545 DEFSYMBOL (Qother_memory_actually_requested);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5546 DEFSYMBOL (Qother_memory_malloc_overhead);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5547 DEFSYMBOL (Qother_memory_dynarr_overhead);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5548 DEFSYMBOL (Qother_memory_gap_overhead);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5549 #endif /* MEMORY_USAGE_STATS */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5550
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5551 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5552 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5553 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5554 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5555 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5556 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5557 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5558 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5559 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5560 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5561 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5562 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5563 DEFSUBR (Fpurecopy);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5564 #ifdef ALLOC_TYPE_STATS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5565 DEFSUBR (Fobject_memory_usage_stats);
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5566 DEFSUBR (Ftotal_object_memory_usage);
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5567 #endif /* ALLOC_TYPE_STATS */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5568 #ifdef MEMORY_USAGE_STATS
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5569 DEFSUBR (Fobject_memory_usage);
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5570 #endif /* MEMORY_USAGE_STATS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5571 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5572 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5573 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5574 #endif
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5575 DEFSUBR (Ftotal_memory_usage);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5576 DEFSUBR (Fconsing_since_gc);
4803
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5577 #ifdef USE_VALGRIND
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5578 DEFSUBR (Fvalgrind_leak_check);
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5579 DEFSUBR (Fvalgrind_quick_leak_check);
5d120deb60ca Enable rudimentary support for valgrind, including functions that tell valgrind
Jerry James <james@xemacs.org>
parents: 4776
diff changeset
5580 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5581 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5583 void
5157
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5584 reinit_vars_of_alloc (void)
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5585 {
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5586 #ifdef MEMORY_USAGE_STATS
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5587 compute_memusage_stats_length ();
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5588 #endif /* MEMORY_USAGE_STATS */
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5589 }
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5590
1fae11d56ad2 redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents: 5146
diff changeset
5591 void
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5592 vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5593 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5594 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5595 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5596 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5597 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5598 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5599 debug_allocation = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5601 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5602 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5603 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5604 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5605 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5606 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5607
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5608 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5609 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5610 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5611 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5612 }