Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 243:f220cc83d72e r20-5b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b20
author cvs
date Mon, 13 Aug 2007 10:17:07 +0200
parents 52952cbfc5b5
children 51092a27c943
comparison
equal deleted inserted replaced
242:fc816b73a05f 243:f220cc83d72e
502 /* lrecords are chained together through their "next.v" field. 502 /* lrecords are chained together through their "next.v" field.
503 * After doing the mark phase, the GC will walk this linked 503 * After doing the mark phase, the GC will walk this linked
504 * list and free any record which hasn't been marked 504 * list and free any record which hasn't been marked
505 */ 505 */
506 static struct lcrecord_header *all_lcrecords; 506 static struct lcrecord_header *all_lcrecords;
507
508 int lrecord_type_index (CONST struct lrecord_implementation *implementation);
509 507
510 void * 508 void *
511 alloc_lcrecord (int size, CONST struct lrecord_implementation *implementation) 509 alloc_lcrecord (int size, CONST struct lrecord_implementation *implementation)
512 { 510 {
513 struct lcrecord_header *lcheader; 511 struct lcrecord_header *lcheader;
992 /* conses are used and freed so often that we set this really high */ 990 /* conses are used and freed so often that we set this really high */
993 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ 991 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
994 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 992 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
995 993
996 #ifdef LRECORD_CONS 994 #ifdef LRECORD_CONS
997 static Lisp_Object mark_cons (Lisp_Object, void (*) (Lisp_Object)); 995 static Lisp_Object
998 static int cons_equal(Lisp_Object, Lisp_Object, int); 996 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
999 extern void print_cons (Lisp_Object, Lisp_Object, int); 997 {
998 if (NILP (XCDR (obj)))
999 return XCAR (obj);
1000 else
1001 (markobj) (XCAR (obj));
1002 return XCDR (obj);
1003 }
1004
1005 static int
1006 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1007 {
1008 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1009 {
1010 ob1 = XCDR(ob1);
1011 ob2 = XCDR(ob2);
1012 if (! CONSP (ob1) || ! CONSP (ob2))
1013 return internal_equal (ob1, ob2, depth + 1);
1014 }
1015 return 0;
1016 }
1017
1000 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, 1018 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1001 mark_cons, print_cons, 0, 1019 mark_cons, print_cons, 0,
1002 cons_equal, 1020 cons_equal,
1003 /* 1021 /*
1004 * No `hash' method needed. 1022 * No `hash' method needed.
1005 * internal_hash knows how to 1023 * internal_hash knows how to
1006 * handle conses. 1024 * handle conses.
1007 */ 1025 */
1008 0, 1026 0,
1009 struct Lisp_Cons); 1027 struct Lisp_Cons);
1010 static Lisp_Object
1011 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1012 {
1013 if (NILP (XCDR (obj)))
1014 return XCAR (obj);
1015 else
1016 (markobj) (XCAR (obj));
1017 return XCDR (obj);
1018 }
1019
1020 static int
1021 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1022 {
1023 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1024 {
1025 ob1 = XCDR(ob1);
1026 ob2 = XCDR(ob2);
1027 if (! CONSP (ob1) || ! CONSP (ob2))
1028 return internal_equal (ob1, ob2, depth + 1);
1029 }
1030 return 0;
1031 }
1032 #endif /* LRECORD_CONS */ 1028 #endif /* LRECORD_CONS */
1033 1029
1034 DEFUN ("cons", Fcons, 2, 2, 0, /* 1030 DEFUN ("cons", Fcons, 2, 2, 0, /*
1035 Create a new cons, give it CAR and CDR as components, and return it. 1031 Create a new cons, give it CAR and CDR as components, and return it.
1036 */ 1032 */
1181 /**********************************************************************/ 1177 /**********************************************************************/
1182 /* Vector allocation */ 1178 /* Vector allocation */
1183 /**********************************************************************/ 1179 /**********************************************************************/
1184 1180
1185 #ifdef LRECORD_VECTOR 1181 #ifdef LRECORD_VECTOR
1186 static Lisp_Object mark_vector (Lisp_Object, void (*) (Lisp_Object)); 1182 static Lisp_Object
1187 static unsigned int size_vector (CONST void *); 1183 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1188 static int vector_equal(Lisp_Object, Lisp_Object, int); 1184 {
1189 extern void print_vector (Lisp_Object, Lisp_Object, int); 1185 struct Lisp_Vector *ptr = XVECTOR (obj);
1186 int len = vector_length (ptr);
1187 int i;
1188
1189 for (i = 0; i < len - 1; i++)
1190 (markobj) (ptr->contents[i]);
1191 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1192 }
1193
1194 static unsigned int
1195 size_vector (CONST void *lheader)
1196 {
1197 struct Lisp_Vector *p = lheader;
1198 /*
1199 * -1 because struct Lisp_Vector includes 1 slot
1200 */
1201 return sizeof (struct Lisp_Vector) +
1202 ((p->size - 1) * sizeof (Lisp_Object)) ;
1203 }
1204
1205 static int
1206 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1207 {
1208 int indice;
1209 int len = XVECTOR_LENGTH (o1);
1210 if (len != XVECTOR_LENGTH (o2))
1211 return 0;
1212 for (indice = 0; indice < len; indice++)
1213 {
1214 if (!internal_equal (XVECTOR_DATA (o1) [indice],
1215 XVECTOR_DATA (o2) [indice],
1216 depth + 1))
1217 return 0;
1218 }
1219 return 1;
1220 }
1221
1190 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, 1222 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1191 mark_vector, print_vector, 0, 1223 mark_vector, print_vector, 0,
1192 vector_equal, 1224 vector_equal,
1193 /* 1225 /*
1194 * No `hash' method needed for 1226 * No `hash' method needed for
1195 * vectors. internal_hash 1227 * vectors. internal_hash
1196 * knows how to handle vectors. 1228 * knows how to handle vectors.
1197 */ 1229 */
1198 0, 1230 0,
1199 size_vector, struct Lisp_Vector); 1231 size_vector, struct Lisp_Vector);
1200 static Lisp_Object
1201 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1202 {
1203 struct Lisp_Vector *ptr = XVECTOR (obj);
1204 int len = vector_length (ptr);
1205 int i;
1206
1207 for (i = 0; i < len - 1; i++)
1208 (markobj) (ptr->contents[i]);
1209 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1210 }
1211
1212 static unsigned int
1213 size_vector (CONST void *lheader)
1214 {
1215 struct Lisp_Vector *p = lheader;
1216 /*
1217 * -1 because struct Lisp_Vector includes 1 slot
1218 */
1219 return sizeof (struct Lisp_Vector) +
1220 ((p->size - 1) * sizeof (Lisp_Object)) ;
1221 }
1222
1223 static int
1224 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1225 {
1226 int indice;
1227 int len = XVECTOR_LENGTH (o1);
1228 if (len != XVECTOR_LENGTH (o2))
1229 return 0;
1230 for (indice = 0; indice < len; indice++)
1231 {
1232 if (!internal_equal (XVECTOR_DATA (o1) [indice],
1233 XVECTOR_DATA (o2) [indice],
1234 depth + 1))
1235 return 0;
1236 }
1237 return 1;
1238 }
1239 1232
1240 /* #### should allocate `small' vectors from a frob-block */ 1233 /* #### should allocate `small' vectors from a frob-block */
1241 static struct Lisp_Vector * 1234 static struct Lisp_Vector *
1242 make_vector_internal (EMACS_INT sizei) 1235 make_vector_internal (EMACS_INT sizei)
1243 { 1236 {
1272 vector_next (p) = all_vectors; 1265 vector_next (p) = all_vectors;
1273 XSETVECTOR (all_vectors, p); 1266 XSETVECTOR (all_vectors, p);
1274 return p; 1267 return p;
1275 } 1268 }
1276 1269
1277 #endif 1270 #endif /* ! LRECORD_VECTOR */
1278 1271
1279 Lisp_Object 1272 Lisp_Object
1280 make_vector (EMACS_INT length, Lisp_Object init) 1273 make_vector (EMACS_INT length, Lisp_Object init)
1281 { 1274 {
1282 EMACS_INT elt; 1275 EMACS_INT elt;
1912 /* strings are used and freed quite often */ 1905 /* strings are used and freed quite often */
1913 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ 1906 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1914 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 1907 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1915 1908
1916 #ifdef LRECORD_STRING 1909 #ifdef LRECORD_STRING
1917 static Lisp_Object mark_string (Lisp_Object, void (*) (Lisp_Object)); 1910 static Lisp_Object
1918 static int string_equal (Lisp_Object, Lisp_Object, int); 1911 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1919 extern void print_string (Lisp_Object, Lisp_Object, int); 1912 {
1913 struct Lisp_String *ptr = XSTRING (obj);
1914
1915 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1916 flush_cached_extent_info (XCAR (ptr->plist));
1917 return ptr->plist;
1918 }
1919
1920 static int
1921 string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1922 {
1923 Bytecount len = XSTRING_LENGTH (o1);
1924 if (len != XSTRING_LENGTH (o2))
1925 return 0;
1926 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
1927 return 0;
1928 return 1;
1929 }
1930
1920 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, 1931 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1921 mark_string, print_string, 1932 mark_string, print_string,
1922 /* 1933 /*
1923 * No `finalize', or `hash' methods. 1934 * No `finalize', or `hash' methods.
1924 * internal_hash already knows how 1935 * internal_hash already knows how
1929 * finalization when using 1940 * finalization when using
1930 * SWEEP_FIXED_TYPE_BLOCK(). 1941 * SWEEP_FIXED_TYPE_BLOCK().
1931 */ 1942 */
1932 0, string_equal, 0, 1943 0, string_equal, 0,
1933 struct Lisp_String); 1944 struct Lisp_String);
1934 static Lisp_Object
1935 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1936 {
1937 struct Lisp_String *ptr = XSTRING (obj);
1938
1939 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1940 flush_cached_extent_info (XCAR (ptr->plist));
1941 return ptr->plist;
1942 }
1943
1944 static int
1945 string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1946 {
1947 Bytecount len = XSTRING_LENGTH (o1);
1948 if (len != XSTRING_LENGTH (o2))
1949 return 0;
1950 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
1951 return 0;
1952 return 1;
1953 }
1954 #endif /* LRECORD_STRING */ 1945 #endif /* LRECORD_STRING */
1955 1946
1956 /* String blocks contain this many useful bytes. */ 1947 /* String blocks contain this many useful bytes. */
1957 #define STRING_CHARS_BLOCK_SIZE \ 1948 #define STRING_CHARS_BLOCK_SIZE \
1958 (8192 - MALLOC_OVERHEAD - ((2 * sizeof (struct string_chars_block *)) \ 1949 (8192 - MALLOC_OVERHEAD - ((2 * sizeof (struct string_chars_block *)) \
2355 -- the finalize method for the lcrecord's type will be called 2346 -- the finalize method for the lcrecord's type will be called
2356 at the time that free_managed_lcrecord() is called. 2347 at the time that free_managed_lcrecord() is called.
2357 2348
2358 */ 2349 */
2359 2350
2360 static Lisp_Object mark_lcrecord_list (Lisp_Object, void (*) (Lisp_Object));
2361 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2362 mark_lcrecord_list, internal_object_printer,
2363 0, 0, 0, struct lcrecord_list);
2364
2365 static Lisp_Object 2351 static Lisp_Object
2366 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) 2352 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2367 { 2353 {
2368 struct lcrecord_list *list = XLCRECORD_LIST (obj); 2354 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2369 Lisp_Object chain = list->free; 2355 Lisp_Object chain = list->free;
2396 } 2382 }
2397 2383
2398 return Qnil; 2384 return Qnil;
2399 } 2385 }
2400 2386
2387 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2388 mark_lcrecord_list, internal_object_printer,
2389 0, 0, 0, struct lcrecord_list);
2401 Lisp_Object 2390 Lisp_Object
2402 make_lcrecord_list (int size, 2391 make_lcrecord_list (int size,
2403 CONST struct lrecord_implementation *implementation) 2392 CONST struct lrecord_implementation *implementation)
2404 { 2393 {
2405 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list, 2394 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2683 v->size = len; 2672 v->size = len;
2684 2673
2685 for (size = 0; size < len; size++) 2674 for (size = 0; size < len; size++)
2686 v->contents[size] = init; 2675 v->contents[size] = init;
2687 2676
2688 XSETVECTOR (new, v); 2677 XSETVECTOR (new, v);
2689 return new; 2678 return new;
2690 } 2679 }
2691 2680
2692 #if 0 2681 #if 0
2693 /* Presently unused */ 2682 /* Presently unused */
4517 { 4506 {
4518 Lisp_Object pl = Qnil; 4507 Lisp_Object pl = Qnil;
4519 Lisp_Object ret[6]; 4508 Lisp_Object ret[6];
4520 int i; 4509 int i;
4521 #ifdef LRECORD_VECTOR 4510 #ifdef LRECORD_VECTOR
4522 int gc_count_vector_total_size; 4511 int gc_count_vector_total_size = 0;
4523 #endif 4512 #endif
4524 4513
4525 if (purify_flag && pure_lossage) 4514 if (purify_flag && pure_lossage)
4526 { 4515 {
4527 return Qnil; 4516 return Qnil;