1 /* The "lrecord" structure (header of a compound lisp object).
2 Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
3 Copyright (C) 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Not in FSF. */
24 #ifndef _XEMACS_LRECORD_H_
25 #define _XEMACS_LRECORD_H_
27 /* The "lrecord" type of Lisp object is used for all object types
28 other than a few simple ones. This allows many types to be
29 implemented but only a few bits required in a Lisp object for
30 type information. (The tradeoff is that each object has its
31 type marked in it, thereby increasing its size.) The first
32 four bytes of all lrecords is either a pointer to a struct
33 lrecord_implementation, which contains methods describing how
34 to process this object, or an index into an array of pointers
35 to struct lrecord_implementations plus some other data bits.
37 Lrecords are of two types: straight lrecords, and lcrecords.
38 Straight lrecords are used for those types of objects that have
39 their own allocation routines (typically allocated out of 2K chunks
40 of memory called `frob blocks'). These objects have a `struct
41 lrecord_header' at the top, containing only the bits needed to find
42 the lrecord_implementation for the object. There are special
43 routines in alloc.c to deal with each such object type.
45 Lcrecords are used for less common sorts of objects that don't
46 do their own allocation. Each such object is malloc()ed
47 individually, and the objects are chained together through
48 a `next' pointer. Lcrecords have a `struct lcrecord_header'
49 at the top, which contains a `struct lrecord_header' and
50 a `next' pointer, and are allocated using alloc_lcrecord().
52 Creating a new lcrecord type is fairly easy; just follow the
53 lead of some existing type (e.g. hash tables). Note that you
54 do not need to supply all the methods (see below); reasonable
55 defaults are provided for many of them. Alternatively, if you're
56 just looking for a way of encapsulating data (which possibly
57 could contain Lisp_Objects in it), you may well be able to use
62 /* It would be better to put the mark-bit together with the
63 following datatype identification field in an 8- or 16-bit
64 integer rather than playing funny games with changing
65 header->implementation and "wasting" 32 bits on the below
66 pointer. The type-id would then be a 7 or 15 bit index into a
67 table of lrecord-implementations rather than a direct pointer.
68 There would be 24 (or 16) bits left over for datatype-specific
71 The below is the simplest thing to do for the present,
72 and doesn't incur that much overhead as most Emacs records
73 are of such a size that the overhead isn't too bad.
74 (The marker datatype is the worst case.)
76 It also has the very very very slight advantage that type-checking
77 involves one memory read (of the "implementation" slot) and a
78 comparison against a link-time constant address rather than a
79 read and a comparison against a variable value. (Variable since
80 it is a very good idea to assign the indices into the hypothetical
81 type-code table dynamically rather that pre-defining them.)
82 I think I remember that Elk Lisp does something like this.
83 Gee, I wonder if some cretin has patented it? */
86 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, we are
87 * implementing the scheme described in the 'It would be better
88 * ...' paragraph above.
90 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
91 /* index into lrecord_implementations_table[] */
93 /* 1 if the object is marked during GC, 0 otherwise. */
95 /* 1 if the object resides in pure (read-only) space */
98 CONST struct lrecord_implementation *implementation;
102 struct lrecord_implementation;
103 int lrecord_type_index (CONST struct lrecord_implementation *implementation);
105 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
106 # define set_lheader_implementation(header,imp) do { \
107 struct lrecord_header* SLI_header = (header); \
108 (SLI_header)->type = lrecord_type_index (imp); \
109 (SLI_header)->mark = 0; \
110 (SLI_header)->pure = 0; \
113 # define set_lheader_implementation(header,imp) \
114 ((void) ((header)->implementation = (imp)))
117 struct lcrecord_header
119 struct lrecord_header lheader;
121 /* The `next' field is normally used to chain all lrecords together
122 so that the GC can find (and free) all of them.
123 `alloc_lcrecord' threads records together.
125 The `next' field may be used for other purposes as long as some
126 other mechanism is provided for letting the GC do its work.
128 For example, the event and marker object types allocate members
129 out of memory chunks, and are able to find all unmarked members
130 by sweeping through the elements of the list of chunks. */
131 struct lcrecord_header *next;
133 /* The `uid' field is just for debugging/printing convenience.
134 Having this slot doesn't hurt us much spacewise, since an
135 lcrecord already has the above slots plus malloc overhead. */
136 unsigned int uid :31;
138 /* The `free' field is a flag that indicates whether this lcrecord
139 is on a "free list". Free lists are used to minimize the number
140 of calls to malloc() when we're repeatedly allocating and freeing
141 a number of the same sort of lcrecord. Lcrecords on a free list
142 always get marked in a different fashion, so we can use this flag
143 as a sanity check to make sure that free lists only have freed
144 lcrecords and there are no freed lcrecords elsewhere. */
145 unsigned int free :1;
148 /* Used for lcrecords in an lcrecord-list. */
149 struct free_lcrecord_header
151 struct lcrecord_header lcheader;
155 /* This as the value of lheader->implementation->finalizer
156 means that this record is already marked */
157 void this_marks_a_marked_record (void *, int);
159 /* see alloc.c for an explanation */
160 Lisp_Object this_one_is_unmarkable (Lisp_Object obj,
161 void (*markobj) (Lisp_Object));
163 struct lrecord_implementation
166 /* This function is called at GC time, to make sure that all Lisp_Objects
167 pointed to by this object get properly marked. It should call
168 the mark_object function on all Lisp_Objects in the object. If
169 the return value is non-nil, it should be a Lisp_Object to be
170 marked (don't call the mark_object function explicitly on it,
171 because the GC routines will do this). Doing it this way reduces
172 recursion, so the object returned should preferably be the one
173 with the deepest level of Lisp_Object pointers. This function
174 can be NULL, meaning no GC marking is necessary. */
175 Lisp_Object (*marker) (Lisp_Object, void (*mark_object) (Lisp_Object));
176 /* This can be NULL if the object is an lcrecord; the
177 default_object_printer() in print.c will be used. */
178 void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag);
179 /* This function is called at GC time when the object is about to
180 be freed, and at dump time (FOR_DISKSAVE will be non-zero in this
181 case). It should perform any necessary cleanup (e.g. freeing
182 malloc()ed memory. This can be NULL, meaning no special
183 finalization is necessary.
185 WARNING: remember that the finalizer is called at dump time even
186 though the object is not being freed. */
187 void (*finalizer) (void *header, int for_disksave);
188 /* This can be NULL, meaning compare objects with EQ(). */
189 int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth);
190 /* This can be NULL, meaning use the Lisp_Object itself as the hash;
191 but *only* if the `equal' function is EQ (if two objects are
192 `equal', they *must* hash to the same value or the hashing won't
194 unsigned long (*hash) (Lisp_Object, int);
195 Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop);
196 int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val);
197 int (*remprop) (Lisp_Object obj, Lisp_Object prop);
198 Lisp_Object (*plist) (Lisp_Object obj);
200 /* Only one of these is non-0. If both are 0, it means that this type
201 is not instantiable by alloc_lcrecord(). */
203 size_t (*size_in_bytes_method) (CONST void *header);
204 /* A unique subtag-code (dynamically) assigned to this datatype. */
205 /* (This is a pointer so the rest of this structure can be read-only.) */
206 int *lrecord_type_index;
207 /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e.
208 one that does not have an lcrecord_header at the front and which
209 is (usually) allocated in frob blocks. We only use this flag for
210 some consistency checking, and that only when error-checking is
215 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
216 extern CONST struct lrecord_implementation *lrecord_implementations_table[];
218 # define XRECORD_LHEADER_IMPLEMENTATION(obj) \
219 (lrecord_implementations_table[XRECORD_LHEADER (obj)->type])
220 # define LHEADER_IMPLEMENTATION(lh) (lrecord_implementations_table[(lh)->type])
222 # define XRECORD_LHEADER_IMPLEMENTATION(obj) \
223 (XRECORD_LHEADER (obj)->implementation)
224 # define LHEADER_IMPLEMENTATION(lh) ((lh)->implementation)
227 extern int gc_in_progress;
229 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
230 # define MARKED_RECORD_P(obj) (gc_in_progress && XRECORD_LHEADER (obj)->mark)
232 # define MARKED_RECORD_P(obj) (gc_in_progress && \
233 XRECORD_LHEADER (obj)->implementation->finalizer == \
234 this_marks_a_marked_record)
237 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
239 # define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark)
240 # define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1))
241 # define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0))
243 #else /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
245 # define MARKED_RECORD_HEADER_P(lheader) \
246 ((lheader)->implementation->finalizer == this_marks_a_marked_record)
247 # define MARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)++))
248 # define UNMARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)--))
250 #endif /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
252 #define UNMARKABLE_RECORD_HEADER_P(lheader) \
253 (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable)
255 /* Declaring the following structures as const puts them in the
256 text (read-only) segment, which makes debugging inconvenient
257 because this segment is not mapped when processing a core-
261 #define CONST_IF_NOT_DEBUG
263 #define CONST_IF_NOT_DEBUG CONST
266 /* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size.
267 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies.
270 #if defined (ERROR_CHECK_TYPECHECK)
271 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)
273 # define DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype)
276 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,structtype) \
277 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,structtype)
279 #define DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \
280 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizeof(structtype),0,1,structtype)
282 #define DEFINE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,structtype) \
283 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,structtype)
285 #define DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,structtype) \
286 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizeof (structtype),0,0,structtype)
288 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,sizer,structtype) \
289 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,0,0,0,0,sizer,structtype)
291 #define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,sizer,structtype) \
292 MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,0,sizer,0,structtype) \
294 #define MAKE_LRECORD_IMPLEMENTATION(name,c_name,marker,printer,nuker,equal,hash,getprop,putprop,remprop,props,size,sizer,basic_p,structtype) \
295 DECLARE_ERROR_CHECK_TYPECHECK(c_name, structtype) \
296 static int lrecord_##c_name##_lrecord_type_index; \
297 CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] = \
298 { { name, marker, printer, nuker, equal, hash, \
299 getprop, putprop, remprop, props, size, sizer, \
300 &(lrecord_##c_name##_lrecord_type_index), basic_p }, \
301 { 0, 0, 0, this_marks_a_marked_record, 0, 0, 0, 0, 0, 0, 0, 0, 0, basic_p } }
303 #define LRECORDP(a) (XTYPE ((a)) == Lisp_Type_Record)
304 #define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a))
306 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
307 # define RECORD_TYPEP(x, ty) \
309 lrecord_implementations_table[XRECORD_LHEADER (x)->type] == (ty))
311 # define RECORD_TYPEP(x, ty) \
312 (LRECORDP (x) && XRECORD_LHEADER (x)->implementation == (ty))
315 /* NOTE: the DECLARE_LRECORD() must come before the associated
316 DEFINE_LRECORD_*() or you will get compile errors.
318 Furthermore, you always need to put the DECLARE_LRECORD() in a header
319 file, and make sure the header file is included in inline.c, even
320 if the type is private to a particular file. Otherwise, you will
321 get undefined references for the error_check_foo() inline function
324 #ifdef ERROR_CHECK_TYPECHECK
326 # define DECLARE_LRECORD(c_name, structtype) \
327 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
328 lrecord_##c_name[]; \
329 INLINE structtype *error_check_##c_name (Lisp_Object obj); \
330 INLINE structtype * \
331 error_check_##c_name (Lisp_Object obj) \
334 assert (RECORD_TYPEP (obj, lrecord_##c_name) || \
335 MARKED_RECORD_P (obj)); \
336 return (structtype *) XPNTR (obj); \
338 extern Lisp_Object Q##c_name##p
340 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
341 INLINE structtype *error_check_##c_name (Lisp_Object obj); \
342 INLINE structtype * \
343 error_check_##c_name (Lisp_Object obj) \
346 assert (XGCTYPE (obj) == type_enum); \
347 return (structtype *) XPNTR (obj); \
349 extern Lisp_Object Q##c_name##p
351 # define XRECORD(x, c_name, structtype) error_check_##c_name (x)
352 # define XNONRECORD(x, c_name, type_enum, structtype) error_check_##c_name (x)
354 # define XSETRECORD(var, p, c_name) do \
356 XSETOBJ (var, Lisp_Type_Record, p); \
357 assert (RECORD_TYPEP (var, lrecord_##c_name) || \
358 MARKED_RECORD_P (var)); \
361 #else /* not ERROR_CHECK_TYPECHECK */
363 # define DECLARE_LRECORD(c_name, structtype) \
364 extern Lisp_Object Q##c_name##p; \
365 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
367 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
368 extern Lisp_Object Q##c_name##p
369 # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x))
370 # define XNONRECORD(x, c_name, type_enum, structtype) \
371 ((structtype *) XPNTR (x))
372 # define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Type_Record, p)
374 #endif /* not ERROR_CHECK_TYPECHECK */
376 #define RECORDP(x, c_name) RECORD_TYPEP (x, lrecord_##c_name)
377 #define GC_RECORDP(x, c_name) gc_record_type_p (x, lrecord_##c_name)
379 /* Note: we now have two different kinds of type-checking macros.
380 The "old" kind has now been renamed CONCHECK_foo. The reason for
381 this is that the CONCHECK_foo macros signal a continuable error,
382 allowing the user (through debug-on-error) to substitute a different
383 value and return from the signal, which causes the lvalue argument
384 to get changed. Quite a lot of code would crash if that happened,
385 because it did things like
390 and later on did XSTRING (XCAR (list)), assuming that the type
391 is correct (when it might be wrong, if the user substituted a
392 correct value in the debugger).
394 To get around this, I made all the CHECK_foo macros signal a
395 non-continuable error. Places where a continuable error is OK
396 (generally only when called directly on the argument of a Lisp
397 primitive) should be changed to use CONCHECK().
399 FSF Emacs does not have this problem because RMS took the cheesy
400 way out and disabled returning from a signal entirely. */
402 #define CONCHECK_RECORD(x, c_name) do { \
403 if (!RECORD_TYPEP (x, lrecord_##c_name)) \
404 x = wrong_type_argument (Q##c_name##p, x); \
406 #define CONCHECK_NONRECORD(x, lisp_enum, predicate) do {\
407 if (XTYPE (x) != lisp_enum) \
408 x = wrong_type_argument (predicate, x); \
410 #define CHECK_RECORD(x, c_name) do { \
411 if (!RECORD_TYPEP (x, lrecord_##c_name)) \
412 dead_wrong_type_argument (Q##c_name##p, x); \
414 #define CHECK_NONRECORD(x, lisp_enum, predicate) do { \
415 if (XTYPE (x) != lisp_enum) \
416 dead_wrong_type_argument (predicate, x); \
419 void *alloc_lcrecord (size_t size, CONST struct lrecord_implementation *);
421 #define alloc_lcrecord_type(type, lrecord_implementation) \
422 ((type *) alloc_lcrecord (sizeof (type), lrecord_implementation))
424 int gc_record_type_p (Lisp_Object frob,
425 CONST struct lrecord_implementation *type);
427 /* Copy the data from one lcrecord structure into another, but don't
428 overwrite the header information. */
430 #define copy_lcrecord(dst, src) \
431 memcpy ((char *) dst + sizeof (struct lcrecord_header), \
432 (char *) src + sizeof (struct lcrecord_header), \
433 sizeof (*dst) - sizeof (struct lcrecord_header))
435 #define zero_lcrecord(lcr) \
436 memset ((char *) lcr + sizeof (struct lcrecord_header), 0, \
437 sizeof (*lcr) - sizeof (struct lcrecord_header))
439 #endif /* _XEMACS_LRECORD_H_ */