Mercurial > hg > xemacs-beta

comparison src/opaque.c @ 424:11054d720c21 r21-2-20

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