Mercurial > hg > xemacs-beta

comparison src/lrecord.h @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 3d6bfa290dbd
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
55 just looking for a way of encapsulating data (which possibly 55 just looking for a way of encapsulating data (which possibly
56 could contain Lisp_Objects in it), you may well be able to use 56 could contain Lisp_Objects in it), you may well be able to use
57 the opaque type. */ 57 the opaque type. */
58 58
59 struct lrecord_header 59 struct lrecord_header
60 { 60 {
61 /* It would be better to put the mark-bit together with the 61 /* It would be better to put the mark-bit together with the
62 * following datatype identification field in an 8- or 16-bit integer 62 following datatype identification field in an 8- or 16-bit
63 * rather than playing funny games with changing header->implementation 63 integer rather than playing funny games with changing
64 * and "wasting" 32 bits on the below pointer. 64 header->implementation and "wasting" 32 bits on the below
65 * The type-id would then be a 7 or 15 65 pointer. The type-id would then be a 7 or 15 bit index into a
66 * bit index into a table of lrecord-implementations rather than a 66 table of lrecord-implementations rather than a direct pointer.
67 * direct pointer. There would be 24 (or 16) bits left over for 67 There would be 24 (or 16) bits left over for datatype-specific
68 * datatype-specific per-instance flags. 68 per-instance flags.
69 * The below is the simplest thing to do for the present, 69
70 * and doesn't incur that much overhead as most Emacs records 70 The below is the simplest thing to do for the present,
71 * are of such a size that the overhead isn't too bad. 71 and doesn't incur that much overhead as most Emacs records
72 * (The marker datatype is the worst case.) 72 are of such a size that the overhead isn't too bad.
73 * It also has the very very very slight advantage that type-checking 73 (The marker datatype is the worst case.)
74 * involves one memory read (of the "implementation" slot) and a 74
75 * comparison against a link-time constant address rather than a 75 It also has the very very very slight advantage that type-checking
76 * read and a comparison against a variable value. (Variable since 76 involves one memory read (of the "implementation" slot) and a
77 * it is a very good idea to assign the indices into the hypothetical 77 comparison against a link-time constant address rather than a
78 * type-code table dynamically rather that pre-defining them.) 78 read and a comparison against a variable value. (Variable since
79 * I think I remember that Elk Lisp does something like this. 79 it is a very good idea to assign the indices into the hypothetical
80 * Gee, I wonder if some cretin has patented it? 80 type-code table dynamically rather that pre-defining them.)
81 */ 81 I think I remember that Elk Lisp does something like this.
82 CONST struct lrecord_implementation *implementation; 82 Gee, I wonder if some cretin has patented it? */
83 }; 83 CONST struct lrecord_implementation *implementation;
84 };
84 #define set_lheader_implementation(header,imp) (header)->implementation=(imp) 85 #define set_lheader_implementation(header,imp) (header)->implementation=(imp)
85 86
86 struct lcrecord_header 87 struct lcrecord_header
87 { 88 {
88 struct lrecord_header lheader; 89 struct lrecord_header lheader;
89 /* The "next" field is normally used to chain all lrecords together 90 /* The "next" field is normally used to chain all lrecords together
90 * so that the GC can find (and free) all of them. 91 so that the GC can find (and free) all of them.
91 * "alloc_lcrecord" threads records together. 92 "alloc_lcrecord" threads records together.
92 * The "next" field may be used for other purposes as long as some 93
93 * other mechanism is provided for letting the GC do its work. 94 The "next" field may be used for other purposes as long as some
94 * (For example, the event and marker datatypes allocates members out 95 other mechanism is provided for letting the GC do its work. (For
95 * of memory chunks, and it are able to find all unmarked 96 example, the event and marker datatypes allocate members out of
96 * events by sweeping through the elements of the list of chunks) 97 memory chunks, and are able to find all unmarked members by
97 */ 98 sweeping through the elements of the list of chunks) */
98 struct lcrecord_header *next; 99 struct lcrecord_header *next;
99 /* This is just for debugging/printing convenience. 100 /* This is just for debugging/printing convenience.
100 Having this slot doesn't hurt us much spacewise, since an lcrecord 101 Having this slot doesn't hurt us much spacewise, since an lcrecord
101 already has the above slots together with malloc overhead. */ 102 already has the above slots together with malloc overhead. */
102 int uid :31; 103 unsigned int uid :31;
103 /* A flag that indicates whether this lcrecord is on a "free list". 104 /* A flag that indicates whether this lcrecord is on a "free list".
104 Free lists are used to minimize the number of calls to malloc() 105 Free lists are used to minimize the number of calls to malloc()
105 when we're repeatedly allocating and freeing a number of the 106 when we're repeatedly allocating and freeing a number of the
106 same sort of lcrecord. Lcrecords on a free list always get 107 same sort of lcrecord. Lcrecords on a free list always get
107 marked in a different fashion, so we can use this flag as a 108 marked in a different fashion, so we can use this flag as a
108 sanity check to make sure that free lists only have freed lcrecords 109 sanity check to make sure that free lists only have freed lcrecords
109 and no freed lcrecords are elsewhere. */ 110 and there are no freed lcrecords elsewhere. */
110 int free :1; 111 unsigned int free :1;
111 }; 112 };
112 113
113 /* Used for lcrecords in an lcrecord-list. */ 114 /* Used for lcrecords in an lcrecord-list. */
114 struct free_lcrecord_header 115 struct free_lcrecord_header
115 { 116 {
116 struct lcrecord_header lcheader; 117 struct lcrecord_header lcheader;
117 Lisp_Object chain; 118 Lisp_Object chain;
118 }; 119 };
119 120
120 /* This as the value of lheader->implementation->finalizer 121 /* This as the value of lheader->implementation->finalizer
121 * means that this record is already marked */ 122 * means that this record is already marked */
122 extern void this_marks_a_marked_record (void *, int); 123 extern void this_marks_a_marked_record (void *, int);
123 124
124 /* see alloc.c for an explanation */ 125 /* see alloc.c for an explanation */
125 extern Lisp_Object this_one_is_unmarkable (Lisp_Object obj, 126 extern Lisp_Object this_one_is_unmarkable (Lisp_Object obj,
126 void (*markobj) (Lisp_Object)); 127 void (*markobj) (Lisp_Object));
127 128
128 struct lrecord_implementation 129 struct lrecord_implementation
129 { 130 {
130 CONST char *name; 131 CONST char *name;
131 /* This function is called at GC time, to make sure that all Lisp_Objects 132 /* This function is called at GC time, to make sure that all Lisp_Objects
132 pointed to by this object get properly marked. It should call 133 pointed to by this object get properly marked. It should call
133 the mark_object function on all Lisp_Objects in the object. If 134 the mark_object function on all Lisp_Objects in the object. If
134 the return value is non-nil, it should be a Lisp_Object to be 135 the return value is non-nil, it should be a Lisp_Object to be
135 marked (don't call the mark_object function explicitly on it, 136 marked (don't call the mark_object function explicitly on it,
136 because the GC routines will do this). Doing it this way reduces 137 because the GC routines will do this). Doing it this way reduces
137 recursion, so the object returned should preferably be the one 138 recursion, so the object returned should preferably be the one
138 with the deepest level of Lisp_Object pointers. This function 139 with the deepest level of Lisp_Object pointers. This function
139 can be NULL, meaning no GC marking is necessary. */ 140 can be NULL, meaning no GC marking is necessary. */
140 Lisp_Object (*marker) (Lisp_Object, void (*mark_object) (Lisp_Object)); 141 Lisp_Object (*marker) (Lisp_Object, void (*mark_object) (Lisp_Object));
141 /* This can be NULL if the object is an lcrecord; the 142 /* This can be NULL if the object is an lcrecord; the
142 default_object_printer() in print.c will be used. */ 143 default_object_printer() in print.c will be used. */
143 void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag); 144 void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag);
144 /* This function is called at GC time when the object is about to 145 /* This function is called at GC time when the object is about to
145 be freed, and at dump time (FOR_DISKSAVE will be non-zero in this 146 be freed, and at dump time (FOR_DISKSAVE will be non-zero in this
146 case). It should perform any necessary cleanup (e.g. freeing 147 case). It should perform any necessary cleanup (e.g. freeing
147 malloc()ed memory. This can be NULL, meaning no special 148 malloc()ed memory. This can be NULL, meaning no special
148 finalization is necessary. 149 finalization is necessary.
149 150
150 WARNING: remember that the finalizer is called at dump time even 151 WARNING: remember that the finalizer is called at dump time even
151 though the object is not being freed. */ 152 though the object is not being freed. */
152 void (*finalizer) (void *header, int for_disksave); 153 void (*finalizer) (void *header, int for_disksave);
153 /* This can be NULL, meaning compare objects with EQ(). */ 154 /* This can be NULL, meaning compare objects with EQ(). */
154 int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth); 155 int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth);
155 /* This can be NULL, meaning use the Lisp_Object itself as the hash; 156 /* This can be NULL, meaning use the Lisp_Object itself as the hash;
156 but *only* if the `equal' function is EQ (if two objects are 157 but *only* if the `equal' function is EQ (if two objects are
157 `equal', they *must* hash to the same value or the hashing won't 158 `equal', they *must* hash to the same value or the hashing won't
158 work). */ 159 work). */
159 unsigned long (*hash) (Lisp_Object, int); 160 unsigned long (*hash) (Lisp_Object, int);
160 Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop); 161 Lisp_Object (*getprop) (Lisp_Object obj, Lisp_Object prop);
161 int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val); 162 int (*putprop) (Lisp_Object obj, Lisp_Object prop, Lisp_Object val);
162 int (*remprop) (Lisp_Object obj, Lisp_Object prop); 163 int (*remprop) (Lisp_Object obj, Lisp_Object prop);
163 Lisp_Object (*plist) (Lisp_Object obj); 164 Lisp_Object (*plist) (Lisp_Object obj);
164 165
165 /* Only one of these is non-0. If both are 0, it means that this type 166 /* Only one of these is non-0. If both are 0, it means that this type
166 is not instantiable by alloc_lcrecord(). */ 167 is not instantiable by alloc_lcrecord(). */
167 unsigned int static_size; 168 unsigned int static_size;
168 unsigned int (*size_in_bytes_method) (CONST void *header); 169 unsigned int (*size_in_bytes_method) (CONST void *header);
169 /* A unique subtag-code (dynamically) assigned to this datatype. */ 170 /* A unique subtag-code (dynamically) assigned to this datatype. */
170 /* (This is a pointer so the rest of this structure can be read-only.) */ 171 /* (This is a pointer so the rest of this structure can be read-only.) */
171 int *lrecord_type_index; 172 int *lrecord_type_index;
172 /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e. 173 /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e.
173 one that does not have an lcrecord_header at the front and which 174 one that does not have an lcrecord_header at the front and which
174 is (usually) allocated in frob blocks. We only use this flag 175 is (usually) allocated in frob blocks. We only use this flag for
175 for some consistency checking, and that only when error-checking 176 some consistency checking, and that only when error-checking is
176 is enabled. */ 177 enabled. */
177 int basic_p; 178 int basic_p;
178 }; 179 };
179 180
180 extern int gc_in_progress; 181 extern int gc_in_progress;
181 182
182 #define MARKED_RECORD_P(obj) (gc_in_progress && \ 183 #define MARKED_RECORD_P(obj) (gc_in_progress && \
183 XRECORD_LHEADER (obj)->implementation->finalizer == \ 184 XRECORD_LHEADER (obj)->implementation->finalizer == \
272 get undefined references for the error_check_foo() inline function 273 get undefined references for the error_check_foo() inline function
273 under GCC. */ 274 under GCC. */
274 275
275 #ifdef ERROR_CHECK_TYPECHECK 276 #ifdef ERROR_CHECK_TYPECHECK
276 277
277 # define DECLARE_LRECORD(c_name, structtype) \ 278 # define DECLARE_LRECORD(c_name, structtype) \
278 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ 279 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
279 lrecord_##c_name[]; \ 280 lrecord_##c_name[]; \
280 INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ 281 INLINE structtype *error_check_##c_name (Lisp_Object _obj); \
281 INLINE structtype * \ 282 INLINE structtype * \
282 error_check_##c_name (Lisp_Object _obj) \ 283 error_check_##c_name (Lisp_Object _obj) \
283 { \ 284 { \
284 XUNMARK (_obj); \ 285 XUNMARK (_obj); \
285 assert (RECORD_TYPEP (_obj, lrecord_##c_name) || \ 286 assert (RECORD_TYPEP (_obj, lrecord_##c_name) || \
286 MARKED_RECORD_P (_obj)); \ 287 MARKED_RECORD_P (_obj)); \
287 return (structtype *) XPNTR (_obj); \ 288 return (structtype *) XPNTR (_obj); \
288 } \ 289 } \
289 extern Lisp_Object Q##c_name##p 290 extern Lisp_Object Q##c_name##p
290 291
291 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ 292 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
292 INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ 293 INLINE structtype *error_check_##c_name (Lisp_Object _obj); \
293 INLINE structtype * \ 294 INLINE structtype * \
294 error_check_##c_name (Lisp_Object _obj) \ 295 error_check_##c_name (Lisp_Object _obj) \
295 { \ 296 { \
296 XUNMARK (_obj); \ 297 XUNMARK (_obj); \
297 assert (XGCTYPE (_obj) == type_enum); \ 298 assert (XGCTYPE (_obj) == type_enum); \
298 return (structtype *) XPNTR (_obj); \ 299 return (structtype *) XPNTR (_obj); \
299 } \ 300 } \
300 extern Lisp_Object Q##c_name##p 301 extern Lisp_Object Q##c_name##p
301 302
302 # define XRECORD(x, c_name, structtype) error_check_##c_name (x) 303 # define XRECORD(x, c_name, structtype) error_check_##c_name (x)
303 # define XNONRECORD(x, c_name, type_enum, structtype) error_check_##c_name (x) 304 # define XNONRECORD(x, c_name, type_enum, structtype) error_check_##c_name (x)
304 305
305 # define XSETRECORD(var, p, c_name) do \ 306 # define XSETRECORD(var, p, c_name) do \
306 { \ 307 { \
307 XSETOBJ (var, Lisp_Record, p); \ 308 XSETOBJ (var, Lisp_Record, p); \
308 assert (RECORD_TYPEP (var, lrecord_##c_name) || \ 309 assert (RECORD_TYPEP (var, lrecord_##c_name) || \
309 MARKED_RECORD_P (var)); \ 310 MARKED_RECORD_P (var)); \
310 } while (0) 311 } while (0)
311 312
312 #else /* not ERROR_CHECK_TYPECHECK */ 313 #else /* not ERROR_CHECK_TYPECHECK */
313 314
314 # define DECLARE_LRECORD(c_name, structtype) \ 315 # define DECLARE_LRECORD(c_name, structtype) \
315 extern Lisp_Object Q##c_name##p; \ 316 extern Lisp_Object Q##c_name##p; \
316 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ 317 extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
317 lrecord_##c_name[] 318 lrecord_##c_name[]
318 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ 319 # define DECLARE_NONRECORD(c_name, type_enum, structtype) \
319 extern Lisp_Object Q##c_name##p 320 extern Lisp_Object Q##c_name##p
320 # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x)) 321 # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x))
321 # define XNONRECORD(x, c_name, type_enum, structtype) \ 322 # define XNONRECORD(x, c_name, type_enum, structtype) \
322 ((structtype *) XPNTR (x)) 323 ((structtype *) XPNTR (x))
323 # define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Record, p) 324 # define XSETRECORD(var, p, c_name) XSETOBJ (var, Lisp_Record, p)
324 325
325 #endif /* not ERROR_CHECK_TYPECHECK */ 326 #endif /* not ERROR_CHECK_TYPECHECK */
326 327
348 primitive) should be changed to use CONCHECK(). 349 primitive) should be changed to use CONCHECK().
349 350
350 FSF Emacs does not have this problem because RMS took the cheesy 351 FSF Emacs does not have this problem because RMS took the cheesy
351 way out and disabled returning from a signal entirely. */ 352 way out and disabled returning from a signal entirely. */
352 353
353 #define CONCHECK_RECORD(x, c_name) do \ 354 #define CONCHECK_RECORD(x, c_name) do \
354 { if (!RECORD_TYPEP (x, lrecord_##c_name)) \ 355 { if (!RECORD_TYPEP (x, lrecord_##c_name)) \
355 x = wrong_type_argument (Q##c_name##p, x); } \ 356 x = wrong_type_argument (Q##c_name##p, x); } \
356 while (0) 357 while (0)
357 #define CONCHECK_NONRECORD(x, lisp_enum, predicate) do \ 358 #define CONCHECK_NONRECORD(x, lisp_enum, predicate) do \
358 { if (XTYPE (x) != lisp_enum) \ 359 { if (XTYPE (x) != lisp_enum) \
359 x = wrong_type_argument (predicate, x); } \ 360 x = wrong_type_argument (predicate, x); } \
360 while (0) 361 while (0)
361 #define CHECK_RECORD(x, c_name) do \ 362 #define CHECK_RECORD(x, c_name) do \
362 { if (!RECORD_TYPEP (x, lrecord_##c_name)) \ 363 { if (!RECORD_TYPEP (x, lrecord_##c_name)) \
363 dead_wrong_type_argument (Q##c_name##p, x); } \ 364 dead_wrong_type_argument (Q##c_name##p, x); } \
364 while (0) 365 while (0)
365 #define CHECK_NONRECORD(x, lisp_enum, predicate) do \ 366 #define CHECK_NONRECORD(x, lisp_enum, predicate) do \
366 { if (XTYPE (x) != lisp_enum) \ 367 { if (XTYPE (x) != lisp_enum) \
367 dead_wrong_type_argument (predicate, x); } \ 368 dead_wrong_type_argument (predicate, x); } \
368 while (0) 369 while (0)
369 370
370 void *alloc_lcrecord (int size, CONST struct lrecord_implementation *); 371 void *alloc_lcrecord (int size, CONST struct lrecord_implementation *);
371 372
372 int gc_record_type_p (Lisp_Object frob, 373 int gc_record_type_p (Lisp_Object frob,
373 CONST struct lrecord_implementation *type); 374 CONST struct lrecord_implementation *type);
374 375
375 /* Copy the data from one lcrecord structure into another, but don't 376 /* Copy the data from one lcrecord structure into another, but don't
376 overwrite the header information. */ 377 overwrite the header information. */
377 378
378 #define copy_lcrecord(dst, src) \ 379 #define copy_lcrecord(dst, src) \
379 memcpy ((char *) dst + sizeof (struct lcrecord_header), \ 380 memcpy ((char *) dst + sizeof (struct lcrecord_header), \
380 (char *) src + sizeof (struct lcrecord_header), \ 381 (char *) src + sizeof (struct lcrecord_header), \
381 sizeof (*dst) - sizeof (struct lcrecord_header)) 382 sizeof (*dst) - sizeof (struct lcrecord_header))
382 383
383 #define zero_lcrecord(lcr) \ 384 #define zero_lcrecord(lcr) \
384 memset ((char *) lcr + sizeof (struct lcrecord_header), 0, \ 385 memset ((char *) lcr + sizeof (struct lcrecord_header), 0, \
385 sizeof (*lcr) - sizeof (struct lcrecord_header)) 386 sizeof (*lcr) - sizeof (struct lcrecord_header))
386 387
387 #endif /* _XEMACS_LRECORD_H_ */ 388 #endif /* _XEMACS_LRECORD_H_ */