Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 6719134a07c2
children a86b2b5e0111
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
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()).
40 */ 35 */
41 36
42 #include <config.h> 37 #include <config.h>
43 #include "lisp.h" 38 #include "lisp.h"
44 #include "opaque.h" 39 #include "opaque.h"
45 #include <stddef.h>
46 40
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. */
54 Lisp_Object Vopaque_ptr_free_list; 41 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 }
79 42
80 /* Should never, ever be called. (except by an external debugger) */ 43 /* Should never, ever be called. (except by an external debugger) */
81 static void 44 static void
82 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 45 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
83 { 46 {
84 CONST Lisp_Opaque *p = XOPAQUE (obj); 47 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;
87 char buf[200]; 48 char buf[200];
88 char size_buf[50];
89 49
90 if (INTP (size_or_chain)) 50 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>",
91 sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p)); 51 (long)(p->size), (unsigned long) 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);
97 write_c_string (buf, printcharfun); 52 write_c_string (buf, printcharfun);
98 } 53 }
99 54
100 static size_t 55 static size_t
101 sizeof_opaque (CONST void *header) 56 sizeof_opaque (const void *header)
102 { 57 {
103 CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header; 58 const Lisp_Opaque *p = (const Lisp_Opaque *) header;
104 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */ 59 return offsetof (Lisp_Opaque, data) + p->size;
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);
108 } 60 }
109 61
110 /* Return an opaque object of size SIZE. 62 /* Return an opaque object of size SIZE.
111 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes. 63 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
112 If DATA is OPAQUE_UNINIT, the object's data is uninitialized. 64 If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
113 Else the object's data is initialized by copying from DATA. */ 65 Else the object's data is initialized by copying from DATA. */
114 Lisp_Object 66 Lisp_Object
115 make_opaque (size_t size, CONST void *data) 67 make_opaque (const void *data, size_t size)
116 { 68 {
117 Lisp_Opaque *p = (Lisp_Opaque *) 69 Lisp_Opaque *p = (Lisp_Opaque *)
118 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque); 70 alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, &lrecord_opaque);
119 p->markfun = 0; 71 p->size = size;
120 p->size_or_chain = make_int (size);
121 72
122 if (data == OPAQUE_CLEAR) 73 if (data == OPAQUE_CLEAR)
123 memset (p->data, '\0', size); 74 memset (p->data, '\0', size);
124 else if (data == OPAQUE_UNINIT) 75 else if (data == OPAQUE_UNINIT)
125 DO_NOTHING; 76 DO_NOTHING;
136 /* This will not work correctly for opaques with subobjects! */ 87 /* This will not work correctly for opaques with subobjects! */
137 88
138 static int 89 static int
139 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) 90 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
140 { 91 {
141 #ifdef DEBUG_XEMACS 92 size_t size;
142 { 93 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
143 /* Egcs 1.1.1 sometimes crashes on INTP (p->size_or_chain) */ 94 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
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 }
156 } 95 }
157 96
158 /* This will not work correctly for opaques with subobjects! */ 97 /* This will not work correctly for opaques with subobjects! */
159 98
160 static unsigned long 99 static unsigned long
161 hash_opaque (Lisp_Object obj, int depth) 100 hash_opaque (Lisp_Object obj, int depth)
162 { 101 {
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
171 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) 102 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
172 return *((unsigned long *) XOPAQUE_DATA (obj)); 103 return *((unsigned long *) XOPAQUE_DATA (obj));
173 else 104 else
174 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj)); 105 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
175 } 106 }
176 107
108 static const struct lrecord_description opaque_description[] = {
109 { XD_END }
110 };
111
177 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, 112 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
178 mark_opaque, print_opaque, 0, 113 0, print_opaque, 0,
179 equal_opaque, hash_opaque, 114 equal_opaque, hash_opaque,
115 opaque_description,
180 sizeof_opaque, Lisp_Opaque); 116 sizeof_opaque, Lisp_Opaque);
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 117
252 /* stuff to handle opaque pointers */ 118 /* stuff to handle opaque pointers */
253 119
120 /* Should never, ever be called. (except by an external debugger) */
121 static void
122 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
123 {
124 const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj);
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
254 Lisp_Object 149 Lisp_Object
255 make_opaque_ptr (CONST void *val) 150 make_opaque_ptr (void *val)
256 { 151 {
257 return allocate_managed_opaque (Vopaque_ptr_free_list, 152 Lisp_Object res = allocate_managed_lcrecord(Vopaque_ptr_free_list);
258 (CONST void *) &val); 153 set_opaque_ptr (res, val);
154 return res;
259 } 155 }
260 156
261 /* Be very very careful with this. Same admonitions as with 157 /* Be very very careful with this. Same admonitions as with
262 free_cons() apply. */ 158 free_cons() apply. */
263 159
264 void 160 void
265 free_opaque_ptr (Lisp_Object ptr) 161 free_opaque_ptr (Lisp_Object ptr)
266 { 162 {
267 free_managed_opaque (Vopaque_ptr_free_list, ptr); 163 free_managed_lcrecord (Vopaque_ptr_free_list, ptr);
268 } 164 }
269 165
270 Lisp_Object 166 void
271 make_opaque_long (long val) 167 reinit_opaque_once_early (void)
272 { 168 {
273 return make_opaque (sizeof (val), (void *) &val); 169 Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), &lrecord_opaque_ptr);
170 staticpro_nodump (&Vopaque_ptr_free_list);
274 } 171 }
275 172
276 void 173 void
277 init_opaque_once_early (void) 174 init_opaque_once_early (void)
278 { 175 {
279 Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0); 176 reinit_opaque_once_early ();
280 staticpro (&Vopaque_ptr_free_list);
281 } 177 }