Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 2f8bb876ab1d
children 41dbb7a9d5f2
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
30 opaque objects cannot be resized. 30 opaque objects cannot be resized.
31 31
32 OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL. Some code 32 OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL. Some code
33 depends on this. As such, opaque objects are a generalization 33 depends on this. As such, opaque objects are a generalization
34 of the Qunbound marker. 34 of the Qunbound marker.
35
36 "Opaque lists" are used to keep track of lots of opaque objects
37 of a particular size so that they can be efficiently "freed" and
38 re-used again without actually entering the Lisp allocation system
39 (and consequently doing a malloc()).
35 */ 40 */
36 41
37 #include <config.h> 42 #include <config.h>
38 #include "lisp.h" 43 #include "lisp.h"
39 #include "opaque.h" 44 #include "opaque.h"
40 45 #include <stddef.h>
46
47 Lisp_Object Qopaquep;
48
49 static int in_opaque_list_marking;
50
51 /* Holds freed opaque objects created with make_opaque_ptr().
52 We do this quite often so it's a noticeable win if we don't
53 create GC junk. */
41 Lisp_Object Vopaque_ptr_free_list; 54 Lisp_Object Vopaque_ptr_free_list;
55
56 static Lisp_Object
57 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
58 {
59 Lisp_Opaque *p = XOPAQUE (obj);
60 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
61 Lisp_Object size_or_chain = p->size_or_chain;
62 #ifdef ERROR_CHECK_GC
63 if (!in_opaque_list_marking)
64 /* size is non-int for objects on an opaque free list. We sure
65 as hell better not be marking any of these objects unless
66 we're marking an opaque list. */
67 assert (GC_INTP (size_or_chain));
68 else
69 /* marking an opaque on the free list doesn't do any recursive
70 markings, so we better not have non-freed opaques on a free
71 list. */
72 assert (!GC_INTP (size_or_chain));
73 #endif
74 if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
75 return OPAQUE_MARKFUN (p) (obj, markobj);
76 else
77 return size_or_chain;
78 }
42 79
43 /* Should never, ever be called. (except by an external debugger) */ 80 /* Should never, ever be called. (except by an external debugger) */
44 static void 81 static void
45 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 82 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
46 { 83 {
47 const Lisp_Opaque *p = XOPAQUE (obj); 84 CONST Lisp_Opaque *p = XOPAQUE (obj);
85 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
86 Lisp_Object size_or_chain = p->size_or_chain;
48 char buf[200]; 87 char buf[200];
49 88 char size_buf[50];
50 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>", 89
51 (long)(p->size), (unsigned long) p); 90 if (INTP (size_or_chain))
91 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
92 else
93 sprintf (size_buf, "freed");
94
95 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
96 size_buf, (unsigned long) p);
52 write_c_string (buf, printcharfun); 97 write_c_string (buf, printcharfun);
53 } 98 }
54 99
55 static size_t 100 static size_t
56 sizeof_opaque (const void *header) 101 sizeof_opaque (CONST void *header)
57 { 102 {
58 const Lisp_Opaque *p = (const Lisp_Opaque *) header; 103 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
59 return offsetof (Lisp_Opaque, data) + p->size; 104 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
105 Lisp_Object size_or_chain = p->size_or_chain;
106 return offsetof (Lisp_Opaque, data)
107 + (GC_INTP (size_or_chain) ? XINT (size_or_chain) : 0);
60 } 108 }
61 109
62 /* Return an opaque object of size SIZE. 110 /* Return an opaque object of size SIZE.
63 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes. 111 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
64 If DATA is OPAQUE_UNINIT, the object's data is uninitialized. 112 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
65 Else the object's data is initialized by copying from DATA. */ 113 Else the object's data is initialized by copying from DATA. */
66 Lisp_Object 114 Lisp_Object
67 make_opaque (const void *data, size_t size) 115 make_opaque (size_t size, CONST void *data)
68 { 116 {
69 Lisp_Opaque *p = (Lisp_Opaque *) 117 Lisp_Opaque *p = (Lisp_Opaque *)
70 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque); 118 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
71 p->size = size; 119 p->markfun = 0;
120 p->size_or_chain = make_int (size);
72 121
73 if (data == OPAQUE_CLEAR) 122 if (data == OPAQUE_CLEAR)
74 memset (p->data, '\0', size); 123 memset (p->data, '\0', size);
75 else if (data == OPAQUE_UNINIT) 124 else if (data == OPAQUE_UNINIT)
76 DO_NOTHING; 125 DO_NOTHING;
87 /* This will not work correctly for opaques with subobjects! */ 136 /* This will not work correctly for opaques with subobjects! */
88 137
89 static int 138 static int
90 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) 139 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
91 { 140 {
92 size_t size; 141 #ifdef DEBUG_XEMACS
93 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) && 142 {
94 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size)); 143 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
144 Lisp_Object size_or_chain_1 = XOPAQUE (obj1)->size_or_chain;
145 Lisp_Object size_or_chain_2 = XOPAQUE (obj2)->size_or_chain;
146 assert (INTP (size_or_chain_1));
147 assert (INTP (size_or_chain_2));
148 assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
149 }
150 #endif
151 {
152 size_t size;
153 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
154 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
155 }
95 } 156 }
96 157
97 /* This will not work correctly for opaques with subobjects! */ 158 /* This will not work correctly for opaques with subobjects! */
98 159
99 static unsigned long 160 static unsigned long
100 hash_opaque (Lisp_Object obj, int depth) 161 hash_opaque (Lisp_Object obj, int depth)
101 { 162 {
163 #ifdef DEBUG_XEMACS
164 {
165 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
166 Lisp_Object size_or_chain = XOPAQUE (obj)->size_or_chain;
167 assert (INTP (size_or_chain));
168 assert (!XOPAQUE_MARKFUN (obj));
169 }
170 #endif
102 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) 171 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
103 return *((unsigned long *) XOPAQUE_DATA (obj)); 172 return *((unsigned long *) XOPAQUE_DATA (obj));
104 else 173 else
105 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj)); 174 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
106 } 175 }
107 176
108 static const struct lrecord_description opaque_description[] = {
109 { XD_END }
110 };
111
112 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, 177 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
113 0, print_opaque, 0, 178 mark_opaque, print_opaque, 0,
114 equal_opaque, hash_opaque, 179 equal_opaque, hash_opaque,
115 opaque_description,
116 sizeof_opaque, Lisp_Opaque); 180 sizeof_opaque, Lisp_Opaque);
117 181
182 static Lisp_Object
183 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
184 {
185 in_opaque_list_marking++;
186 markobj (XOPAQUE_LIST (obj)->free);
187 in_opaque_list_marking--;
188 return Qnil;
189 }
190
191 Lisp_Object
192 make_opaque_list (size_t size,
193 Lisp_Object (*markfun) (Lisp_Object obj,
194 void (*markobj) (Lisp_Object)))
195 {
196 Lisp_Object val;
197 Lisp_Opaque_List *p =
198 alloc_lcrecord_type (Lisp_Opaque_List, &lrecord_opaque_list);
199
200 p->markfun = markfun;
201 p->size = size;
202 p->free = Qnil;
203 XSETOPAQUE_LIST (val, p);
204 return val;
205 }
206
207 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
208 mark_opaque_list, internal_object_printer,
209 0, 0, 0, Lisp_Opaque_List);
210
211 Lisp_Object
212 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
213 {
214 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
215 Lisp_Object val;
216
217 if (!NILP (li->free))
218 {
219 val = li->free;
220 li->free = XOPAQUE (val)->size_or_chain;
221 #ifdef ERROR_CHECK_GC
222 assert (NILP (li->free) || OPAQUEP (li->free));
223 #endif
224 XOPAQUE (val)->size_or_chain = make_int (li->size);
225 if (data)
226 memcpy (XOPAQUE (val)->data, data, li->size);
227 else
228 memset (XOPAQUE (val)->data, 0, li->size);
229 }
230 else
231 val = make_opaque (li->size, data);
232 XOPAQUE (val)->markfun = li->markfun;
233 return val;
234 }
235
236 void
237 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
238 {
239 Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
240
241 #ifdef ERROR_CHECK_GC
242 {
243 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */
244 Lisp_Object size_or_chain = XOPAQUE (opaque)->size_or_chain;
245 assert (INTP (size_or_chain));
246 }
247 #endif
248 XOPAQUE (opaque)->size_or_chain = li->free;
249 li->free = opaque;
250 }
251
118 /* stuff to handle opaque pointers */ 252 /* stuff to handle opaque pointers */
119 253
120 /* Should never, ever be called. (except by an external debugger) */ 254 Lisp_Object
121 static void 255 make_opaque_ptr (CONST void *val)
122 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 256 {
123 { 257 return allocate_managed_opaque (Vopaque_ptr_free_list,
124 const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj); 258 (CONST void *) &val);
125 char buf[200];
126
127 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%lx>",
128 (long)(p->ptr), (unsigned long) p);
129 write_c_string (buf, printcharfun);
130 }
131
132 static int
133 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int depth)
134 {
135 return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr);
136 }
137
138 static unsigned long
139 hash_opaque_ptr (Lisp_Object obj, int depth)
140 {
141 return (unsigned long) XOPAQUE_PTR (obj)->ptr;
142 }
143
144 DEFINE_LRECORD_IMPLEMENTATION ("opaque-ptr", opaque_ptr,
145 0, print_opaque_ptr, 0,
146 equal_opaque_ptr, hash_opaque_ptr, 0,
147 Lisp_Opaque_Ptr);
148
149 Lisp_Object
150 make_opaque_ptr (void *val)
151 {
152 Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
153 set_opaque_ptr (res, val);
154 return res;
155 } 259 }
156 260
157 /* Be very very careful with this. Same admonitions as with 261 /* Be very very careful with this. Same admonitions as with
158 free_cons() apply. */ 262 free_cons() apply. */
159 263
160 void 264 void
161 free_opaque_ptr (Lisp_Object ptr) 265 free_opaque_ptr (Lisp_Object ptr)
162 { 266 {
163 free_managed_lcrecord (Vopaque_ptr_free_list, ptr); 267 free_managed_opaque (Vopaque_ptr_free_list, ptr);
164 } 268 }
165 269
166 void 270 Lisp_Object
167 reinit_opaque_once_early (void) 271 make_opaque_long (long val)
168 { 272 {
169 Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), &lrecord_opaque_ptr); 273 return make_opaque (sizeof (val), (void *) &val);
170 staticpro_nodump (&Vopaque_ptr_free_list);
171 } 274 }
172 275
173 void 276 void
174 init_opaque_once_early (void) 277 init_opaque_once_early (void)
175 { 278 {
176 INIT_LRECORD_IMPLEMENTATION (opaque); 279 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
177 INIT_LRECORD_IMPLEMENTATION (opaque_ptr); 280 staticpro (&Vopaque_ptr_free_list);
178 281 }
179 reinit_opaque_once_early ();
180 }