Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 207:e45d5e7c476e r20-4b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b2
author cvs
date Mon, 13 Aug 2007 10:03:52 +0200
parents a2f645c6b9f8
children 78478c60bfcd
comparison
equal deleted inserted replaced
206:d3e9274cbc4e 207:e45d5e7c476e
60 /* #define GDB_SUCKS */ 60 /* #define GDB_SUCKS */
61 61
62 /* #define VERIFY_STRING_CHARS_INTEGRITY */ 62 /* #define VERIFY_STRING_CHARS_INTEGRITY */
63 63
64 /* Define this to see where all that space is going... */ 64 /* Define this to see where all that space is going... */
65 /* But the length of the printout is obnoxious, so limit it to testers */
66 #ifdef DEBUG_XEMACS
65 #define PURESTAT 67 #define PURESTAT
68 #endif
66 69
67 /* Define this to use malloc/free with no freelist for all datatypes, 70 /* Define this to use malloc/free with no freelist for all datatypes,
68 the hope being that some debugging tools may help detect 71 the hope being that some debugging tools may help detect
69 freed memory references */ 72 freed memory references */
70 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ 73 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
484 { 487 {
485 void *p = xmalloc (size); 488 void *p = xmalloc (size);
486 char *lim = ((char *) p) + size; 489 char *lim = ((char *) p) + size;
487 Lisp_Object val = Qnil; 490 Lisp_Object val = Qnil;
488 491
489 XSETCONS (val, lim); 492 XSETOBJ (val, Lisp_Type_Record, lim);
490 if ((char *) XCONS (val) != lim) 493 if ((char *) XPNTR (val) != lim)
491 { 494 {
492 xfree (p); 495 xfree (p);
493 memory_full (); 496 memory_full ();
494 } 497 }
495 return p; 498 return p;
496 } 499 }
497
498
499 #define MARKED_RECORD_HEADER_P(lheader) \
500 (((lheader)->implementation->finalizer) == this_marks_a_marked_record)
501 #define UNMARKABLE_RECORD_HEADER_P(lheader) \
502 (((lheader)->implementation->marker) == this_one_is_unmarkable)
503 #define MARK_RECORD_HEADER(lheader) \
504 do { (((lheader)->implementation)++); } while (0)
505 #define UNMARK_RECORD_HEADER(lheader) \
506 do { (((lheader)->implementation)--); } while (0)
507 500
508 501
509 /* lrecords are chained together through their "next.v" field. 502 /* lrecords are chained together through their "next.v" field.
510 * After doing the mark phase, the GC will walk this linked 503 * After doing the mark phase, the GC will walk this linked
511 * list and free any record which hasn't been marked 504 * list and free any record which hasn't been marked
989 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); 982 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
990 /* conses are used and freed so often that we set this really high */ 983 /* conses are used and freed so often that we set this really high */
991 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ 984 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
992 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 985 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
993 986
987 #ifdef LRECORD_CONS
988 static Lisp_Object mark_cons (Lisp_Object, void (*) (Lisp_Object));
989 static int cons_equal(Lisp_Object, Lisp_Object, int);
990 extern void print_cons (Lisp_Object, Lisp_Object, int);
991 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
992 mark_cons, print_cons, 0,
993 cons_equal,
994 /*
995 * No `hash' method needed.
996 * internal_hash knows how to
997 * handle conses.
998 */
999 0,
1000 struct Lisp_Cons);
1001 static Lisp_Object
1002 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1003 {
1004 if (NILP (XCDR (obj)))
1005 return XCAR (obj);
1006 else
1007 (markobj) (XCAR (obj));
1008 return XCDR (obj);
1009 }
1010
1011 static int
1012 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1013 {
1014 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1015 {
1016 ob1 = XCDR(ob1);
1017 ob2 = XCDR(ob2);
1018 if (! CONSP (ob1) || ! CONSP (ob2))
1019 return internal_equal (ob1, ob2, depth + 1);
1020 }
1021 return 0;
1022 }
1023 #endif /* LRECORD_CONS */
1024
994 DEFUN ("cons", Fcons, 2, 2, 0, /* 1025 DEFUN ("cons", Fcons, 2, 2, 0, /*
995 Create a new cons, give it CAR and CDR as components, and return it. 1026 Create a new cons, give it CAR and CDR as components, and return it.
996 */ 1027 */
997 (car, cdr)) 1028 (car, cdr))
998 { 1029 {
999 /* This cannot GC. */ 1030 /* This cannot GC. */
1000 Lisp_Object val = Qnil; 1031 Lisp_Object val = Qnil;
1001 struct Lisp_Cons *c; 1032 struct Lisp_Cons *c;
1002 1033
1003 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); 1034 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1035 #ifdef LRECORD_CONS
1036 set_lheader_implementation (&(c->lheader), lrecord_cons);
1037 #endif
1004 XSETCONS (val, c); 1038 XSETCONS (val, c);
1005 XCAR (val) = car; 1039 c->car = car;
1006 XCDR (val) = cdr; 1040 c->cdr = cdr;
1007 return val; 1041 return val;
1008 } 1042 }
1009 1043
1010 /* This is identical to Fcons() but it used for conses that we're 1044 /* This is identical to Fcons() but it used for conses that we're
1011 going to free later, and is useful when trying to track down 1045 going to free later, and is useful when trying to track down
1015 { 1049 {
1016 Lisp_Object val = Qnil; 1050 Lisp_Object val = Qnil;
1017 struct Lisp_Cons *c; 1051 struct Lisp_Cons *c;
1018 1052
1019 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); 1053 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1054 #ifdef LRECORD_CONS
1055 set_lheader_implementation (&(c->lheader), lrecord_cons);
1056 #endif
1020 XSETCONS (val, c); 1057 XSETCONS (val, c);
1021 XCAR (val) = car; 1058 XCAR (val) = car;
1022 XCDR (val) = cdr; 1059 XCDR (val) = cdr;
1023 return val; 1060 return val;
1024 } 1061 }
1134 1171
1135 /**********************************************************************/ 1172 /**********************************************************************/
1136 /* Vector allocation */ 1173 /* Vector allocation */
1137 /**********************************************************************/ 1174 /**********************************************************************/
1138 1175
1176 #ifdef LRECORD_VECTOR
1177 static Lisp_Object mark_vector (Lisp_Object, void (*) (Lisp_Object));
1178 static unsigned int size_vector (CONST void *);
1179 static int vector_equal(Lisp_Object, Lisp_Object, int);
1180 extern void print_vector (Lisp_Object, Lisp_Object, int);
1181 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1182 mark_vector, print_vector, 0,
1183 vector_equal,
1184 /*
1185 * No `hash' method needed for
1186 * vectors. internal_hash
1187 * knows how to handle vectors.
1188 */
1189 0,
1190 size_vector, struct Lisp_Vector);
1191 static Lisp_Object
1192 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1193 {
1194 struct Lisp_Vector *ptr = XVECTOR (obj);
1195 int len = vector_length (ptr);
1196 int i;
1197
1198 for (i = 0; i < len - 1; i++)
1199 (markobj) (ptr->contents[i]);
1200 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1201 }
1202
1203 static unsigned int
1204 size_vector (CONST void *lheader)
1205 {
1206 struct Lisp_Vector *p = lheader;
1207 /*
1208 * -1 because struct Lisp_Vector includes 1 slot
1209 */
1210 return sizeof (struct Lisp_Vector) +
1211 ((p->size - 1) * sizeof (Lisp_Object)) ;
1212 }
1213
1214 static int
1215 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1216 {
1217 int indice;
1218 int len = XVECTOR_LENGTH (o1);
1219 if (len != XVECTOR_LENGTH (o2))
1220 return 0;
1221 for (indice = 0; indice < len; indice++)
1222 {
1223 if (!internal_equal (XVECTOR_DATA (o1) [indice],
1224 XVECTOR_DATA (o2) [indice],
1225 depth + 1))
1226 return 0;
1227 }
1228 return 1;
1229 }
1230
1231 /* #### should allocate `small' vectors from a frob-block */
1232 static struct Lisp_Vector *
1233 make_vector_internal (EMACS_INT sizei)
1234 {
1235 EMACS_INT sizem = (sizeof (struct Lisp_Vector)
1236 /* -1 because struct Lisp_Vector includes 1 slot */
1237 + (sizei - 1) * sizeof (Lisp_Object)
1238 );
1239 struct Lisp_Vector *p = alloc_lcrecord (sizem, lrecord_vector);
1240
1241 p->size = sizei;
1242 return p;
1243 }
1244
1245 #else /* ! LRECORD_VECTOR */
1246
1139 static Lisp_Object all_vectors; 1247 static Lisp_Object all_vectors;
1140 1248
1141 /* #### should allocate `small' vectors from a frob-block */ 1249 /* #### should allocate `small' vectors from a frob-block */
1142 static struct Lisp_Vector * 1250 static struct Lisp_Vector *
1143 make_vector_internal (EMACS_INT sizei) 1251 make_vector_internal (EMACS_INT sizei)
1146 /* -1 because struct Lisp_Vector includes 1 slot, 1254 /* -1 because struct Lisp_Vector includes 1 slot,
1147 * +1 to account for vector_next */ 1255 * +1 to account for vector_next */
1148 + (sizei - 1 + 1) * sizeof (Lisp_Object) 1256 + (sizei - 1 + 1) * sizeof (Lisp_Object)
1149 ); 1257 );
1150 struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem); 1258 struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem);
1151 #ifdef LRECORD_VECTOR
1152 set_lheader_implementation (&(p->lheader), lrecord_vector);
1153 #endif
1154 1259
1155 INCREMENT_CONS_COUNTER (sizem, "vector"); 1260 INCREMENT_CONS_COUNTER (sizem, "vector");
1156 1261
1157 p->size = sizei; 1262 p->size = sizei;
1158 vector_next (p) = all_vectors; 1263 vector_next (p) = all_vectors;
1159 XSETVECTOR (all_vectors, p); 1264 XSETVECTOR (all_vectors, p);
1160 return p; 1265 return p;
1161 } 1266 }
1267
1268 #endif
1162 1269
1163 Lisp_Object 1270 Lisp_Object
1164 make_vector (EMACS_INT length, Lisp_Object init) 1271 make_vector (EMACS_INT length, Lisp_Object init)
1165 { 1272 {
1166 EMACS_INT elt; 1273 EMACS_INT elt;
1792 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String); 1899 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1793 /* strings are used and freed quite often */ 1900 /* strings are used and freed quite often */
1794 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ 1901 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1795 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 1902 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1796 1903
1904 #ifdef LRECORD_STRING
1905 static Lisp_Object mark_string (Lisp_Object, void (*) (Lisp_Object));
1906 static int string_equal (Lisp_Object, Lisp_Object, int);
1907 extern void print_string (Lisp_Object, Lisp_Object, int);
1908 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1909 mark_string, print_string,
1910 /*
1911 * No `finalize', or `hash' methods.
1912 * internal_hash already knows how
1913 * to hash strings and finalization
1914 * is done with the
1915 * ADDITIONAL_FREE_string macro,
1916 * which is the standard way to do
1917 * finalization when using
1918 * SWEEP_FIXED_TYPE_BLOCK().
1919 */
1920 0, string_equal, 0,
1921 struct Lisp_String);
1922 static Lisp_Object
1923 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1924 {
1925 struct Lisp_String *ptr = XSTRING (obj);
1926
1927 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1928 flush_cached_extent_info (XCAR (ptr->plist));
1929 return ptr->plist;
1930 }
1931
1932 static int
1933 string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1934 {
1935 Bytecount len = XSTRING_LENGTH (o1);
1936 if (len != XSTRING_LENGTH (o2))
1937 return 0;
1938 if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
1939 return 0;
1940 return 1;
1941 }
1942 #endif /* LRECORD_STRING */
1943
1797 /* String blocks contain this many useful bytes. */ 1944 /* String blocks contain this many useful bytes. */
1798 #define STRING_CHARS_BLOCK_SIZE \ 1945 #define STRING_CHARS_BLOCK_SIZE \
1799 (8192 - MALLOC_OVERHEAD - ((2 * sizeof (struct string_chars_block *)) \ 1946 (8192 - MALLOC_OVERHEAD - ((2 * sizeof (struct string_chars_block *)) \
1800 + sizeof (EMACS_INT))) 1947 + sizeof (EMACS_INT)))
1801 /* Block header for small strings. */ 1948 /* Block header for small strings. */
1903 if ((length < 0) || (fullsize <= 0)) 2050 if ((length < 0) || (fullsize <= 0))
1904 abort (); 2051 abort ();
1905 2052
1906 /* Allocate the string header */ 2053 /* Allocate the string header */
1907 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s); 2054 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2055 #ifdef LRECORD_STRING
2056 set_lheader_implementation (&(s->lheader), lrecord_string);
2057 #endif
1908 2058
1909 s_chars = allocate_string_chars_struct (s, fullsize); 2059 s_chars = allocate_string_chars_struct (s, fullsize);
1910 2060
1911 set_string_data (s, &(s_chars->chars[0])); 2061 set_string_data (s, &(s_chars->chars[0]));
1912 set_string_length (s, length); 2062 set_string_length (s, length);
2355 2505
2356 if (!check_purespace (size)) 2506 if (!check_purespace (size))
2357 return make_string (data, length); 2507 return make_string (data, length);
2358 2508
2359 s = (struct Lisp_String *) (PUREBEG + pureptr); 2509 s = (struct Lisp_String *) (PUREBEG + pureptr);
2510 #ifdef LRECORD_STRING
2511 set_lheader_implementation (&(s->lheader), lrecord_string);
2512 #endif
2360 set_string_length (s, length); 2513 set_string_length (s, length);
2361 if (no_need_to_copy_data) 2514 if (no_need_to_copy_data)
2362 { 2515 {
2363 set_string_data (s, (Bufbyte *) data); 2516 set_string_data (s, (Bufbyte *) data);
2364 } 2517 }
2402 2555
2403 Lisp_Object 2556 Lisp_Object
2404 pure_cons (Lisp_Object car, Lisp_Object cdr) 2557 pure_cons (Lisp_Object car, Lisp_Object cdr)
2405 { 2558 {
2406 Lisp_Object new; 2559 Lisp_Object new;
2560 struct Lisp_Cons *c;
2407 2561
2408 if (!check_purespace (sizeof (struct Lisp_Cons))) 2562 if (!check_purespace (sizeof (struct Lisp_Cons)))
2409 return Fcons (Fpurecopy (car), Fpurecopy (cdr)); 2563 return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2410 2564
2411 XSETCONS (new, PUREBEG + pureptr); 2565 c = (struct Lisp_Cons *) (PUREBEG + pureptr);
2566 #ifdef LRECORD_CONS
2567 set_lheader_implementation (&(c->lheader), lrecord_cons);
2568 #endif
2412 pureptr += sizeof (struct Lisp_Cons); 2569 pureptr += sizeof (struct Lisp_Cons);
2413 bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons)); 2570 bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons));
2414 2571
2415 XCAR (new) = Fpurecopy (car); 2572 c->car = Fpurecopy (car);
2416 XCDR (new) = Fpurecopy (cdr); 2573 c->cdr = Fpurecopy (cdr);
2574 XSETCONS (new, c);
2417 return new; 2575 return new;
2418 } 2576 }
2419 2577
2420 Lisp_Object 2578 Lisp_Object
2421 pure_list (int nargs, Lisp_Object *args) 2579 pure_list (int nargs, Lisp_Object *args)
2480 2638
2481 Lisp_Object 2639 Lisp_Object
2482 make_pure_vector (EMACS_INT len, Lisp_Object init) 2640 make_pure_vector (EMACS_INT len, Lisp_Object init)
2483 { 2641 {
2484 Lisp_Object new; 2642 Lisp_Object new;
2643 struct Lisp_Vector *v;
2485 EMACS_INT size = (sizeof (struct Lisp_Vector) 2644 EMACS_INT size = (sizeof (struct Lisp_Vector)
2486 + (len - 1) * sizeof (Lisp_Object)); 2645 + (len - 1) * sizeof (Lisp_Object));
2487 2646
2488 init = Fpurecopy (init); 2647 init = Fpurecopy (init);
2489 2648
2490 if (!check_purespace (size)) 2649 if (!check_purespace (size))
2491 return make_vector (len, init); 2650 return make_vector (len, init);
2492 2651
2493 XSETVECTOR (new, PUREBEG + pureptr); 2652 v = (struct Lisp_Vector *) (PUREBEG + pureptr);
2653 #ifdef LRECORD_VECTOR
2654 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2655 #endif
2494 pureptr += size; 2656 pureptr += size;
2495 bump_purestat (&purestat_vector_all, size); 2657 bump_purestat (&purestat_vector_all, size);
2496 2658
2497 XVECTOR_LENGTH (new) = len; 2659 v->size = len;
2498 2660
2499 for (size = 0; size < len; size++) 2661 for (size = 0; size < len; size++)
2500 XVECTOR_DATA (new)[size] = init; 2662 v->contents[size] = init;
2501 2663
2664 XSETVECTOR (new, v);
2502 return new; 2665 return new;
2503 } 2666 }
2504 2667
2505 #if 0 2668 #if 0
2506 /* Presently unused */ 2669 /* Presently unused */
2530 int i; 2693 int i;
2531 if (!purify_flag) 2694 if (!purify_flag)
2532 return obj; 2695 return obj;
2533 2696
2534 if (!POINTER_TYPE_P (XTYPE (obj)) 2697 if (!POINTER_TYPE_P (XTYPE (obj))
2535 || PURIFIED (XPNTR (obj))) 2698 || PURIFIED (XPNTR (obj))
2699 /* happens when bootstrapping Qnil */
2700 || EQ (obj, Qnull_pointer))
2536 return obj; 2701 return obj;
2537 2702
2538 switch (XTYPE (obj)) 2703 switch (XTYPE (obj))
2539 { 2704 {
2705 #ifndef LRECORD_CONS
2540 case Lisp_Type_Cons: 2706 case Lisp_Type_Cons:
2541 return pure_cons (XCAR (obj), XCDR (obj)); 2707 return pure_cons (XCAR (obj), XCDR (obj));
2542 2708 #endif
2709
2710 #ifndef LRECORD_STRING
2543 case Lisp_Type_String: 2711 case Lisp_Type_String:
2544 return make_pure_string (XSTRING_DATA (obj), 2712 return make_pure_string (XSTRING_DATA (obj),
2545 XSTRING_LENGTH (obj), 2713 XSTRING_LENGTH (obj),
2546 XSTRING (obj)->plist, 2714 XSTRING (obj)->plist,
2547 0); 2715 0);
2716 #endif /* ! LRECORD_STRING */
2548 2717
2549 #ifndef LRECORD_VECTOR 2718 #ifndef LRECORD_VECTOR
2550 case Lisp_Type_Vector: 2719 case Lisp_Type_Vector:
2551 { 2720 {
2552 struct Lisp_Vector *o = XVECTOR (obj); 2721 struct Lisp_Vector *o = XVECTOR (obj);
2571 n->arglist = Fpurecopy (o->arglist); 2740 n->arglist = Fpurecopy (o->arglist);
2572 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive); 2741 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2573 n->maxdepth = o->maxdepth; 2742 n->maxdepth = o->maxdepth;
2574 return new; 2743 return new;
2575 } 2744 }
2745 #ifdef LRECORD_CONS
2746 else if (CONSP (obj))
2747 return pure_cons (XCAR (obj), XCDR (obj));
2748 #endif /* LRECORD_CONS */
2749 #ifdef LRECORD_VECTOR
2750 else if (VECTORP (obj))
2751 {
2752 struct Lisp_Vector *o = XVECTOR (obj);
2753 Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2754 for (i = 0; i < vector_length (o); i++)
2755 XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2756 return new;
2757 }
2758 #endif /* LRECORD_VECTOR */
2759 #ifdef LRECORD_STRING
2760 else if (STRINGP (obj))
2761 {
2762 return make_pure_string (XSTRING_DATA (obj),
2763 XSTRING_LENGTH (obj),
2764 XSTRING (obj)->plist,
2765 0);
2766 }
2767 #endif /* LRECORD_STRING */
2576 #ifdef LISP_FLOAT_TYPE 2768 #ifdef LISP_FLOAT_TYPE
2577 else if (FLOATP (obj)) 2769 else if (FLOATP (obj))
2578 return make_pure_float (float_data (XFLOAT (obj))); 2770 return make_pure_float (float_data (XFLOAT (obj)));
2579 #endif /* LISP_FLOAT_TYPE */ 2771 #endif /* LISP_FLOAT_TYPE */
2580 else if (!SYMBOLP (obj)) 2772 else if (!SYMBOLP (obj))
2774 static void 2966 static void
2775 mark_object (Lisp_Object obj) 2967 mark_object (Lisp_Object obj)
2776 { 2968 {
2777 tail_recurse: 2969 tail_recurse:
2778 2970
2971 if (EQ (obj, Qnull_pointer))
2972 return;
2779 if (!POINTER_TYPE_P (XGCTYPE (obj))) 2973 if (!POINTER_TYPE_P (XGCTYPE (obj)))
2780 return; 2974 return;
2781 if (PURIFIED (XPNTR (obj))) 2975 if (PURIFIED (XPNTR (obj)))
2782 return; 2976 return;
2783 switch (XGCTYPE (obj)) 2977 switch (XGCTYPE (obj))
2784 { 2978 {
2979 #ifndef LRECORD_CONS
2785 case Lisp_Type_Cons: 2980 case Lisp_Type_Cons:
2786 { 2981 {
2787 struct Lisp_Cons *ptr = XCONS (obj); 2982 struct Lisp_Cons *ptr = XCONS (obj);
2788 if (CONS_MARKED_P (ptr)) 2983 if (CONS_MARKED_P (ptr))
2789 break; 2984 break;
2798 mark_object (ptr->car); 2993 mark_object (ptr->car);
2799 obj = ptr->cdr; 2994 obj = ptr->cdr;
2800 } 2995 }
2801 goto tail_recurse; 2996 goto tail_recurse;
2802 } 2997 }
2998 #endif
2803 2999
2804 case Lisp_Type_Record: 3000 case Lisp_Type_Record:
2805 /* case Lisp_Symbol_Value_Magic: */ 3001 /* case Lisp_Symbol_Value_Magic: */
2806 { 3002 {
2807 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 3003 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2823 } 3019 }
2824 } 3020 }
2825 } 3021 }
2826 break; 3022 break;
2827 3023
3024 #ifndef LRECORD_STRING
2828 case Lisp_Type_String: 3025 case Lisp_Type_String:
2829 { 3026 {
2830 struct Lisp_String *ptr = XSTRING (obj); 3027 struct Lisp_String *ptr = XSTRING (obj);
2831 3028
2832 if (!XMARKBIT (ptr->plist)) 3029 if (!XMARKBIT (ptr->plist))
2838 obj = ptr->plist; 3035 obj = ptr->plist;
2839 goto tail_recurse; 3036 goto tail_recurse;
2840 } 3037 }
2841 } 3038 }
2842 break; 3039 break;
3040 #endif /* ! LRECORD_STRING */
2843 3041
2844 #ifndef LRECORD_VECTOR 3042 #ifndef LRECORD_VECTOR
2845 case Lisp_Type_Vector: 3043 case Lisp_Type_Vector:
2846 { 3044 {
2847 struct Lisp_Vector *ptr = XVECTOR (obj); 3045 struct Lisp_Vector *ptr = XVECTOR (obj);
2871 { 3069 {
2872 XMARK (sym->plist); 3070 XMARK (sym->plist);
2873 mark_object (sym->value); 3071 mark_object (sym->value);
2874 mark_object (sym->function); 3072 mark_object (sym->function);
2875 { 3073 {
2876 /* Open-code mark_string */ 3074 /*
2877 /* symbol->name is a struct Lisp_String *, not a Lisp_Object */ 3075 * symbol->name is a struct Lisp_String *, not a
2878 struct Lisp_String *pname = sym->name; 3076 * Lisp_Object. Fix it up and pass to mark_object.
2879 if (!PURIFIED (pname) 3077 */
2880 && !XMARKBIT (pname->plist)) 3078 Lisp_Object symname;
2881 { 3079 XSETSTRING(symname, sym->name);
2882 XMARK (pname->plist); 3080 mark_object(symname);
2883 mark_object (pname->plist);
2884 }
2885 } 3081 }
2886 if (!symbol_next (sym)) 3082 if (!symbol_next (sym))
2887 { 3083 {
2888 obj = sym->plist; 3084 obj = sym->plist;
2889 goto tail_recurse; 3085 goto tail_recurse;
2934 { 3130 {
2935 idiot_c_doesnt_have_closures += pure_sizeof (obj, 1); 3131 idiot_c_doesnt_have_closures += pure_sizeof (obj, 1);
2936 } 3132 }
2937 #endif /* unused */ 3133 #endif /* unused */
2938 3134
3135 static int
3136 pure_string_sizeof(Lisp_Object obj)
3137 {
3138 struct Lisp_String *ptr = XSTRING (obj);
3139 int size = string_length (ptr);
3140
3141 if (string_data (ptr) !=
3142 (unsigned char *) ptr + sizeof (struct Lisp_String))
3143 {
3144 /* string-data not allocated contiguously.
3145 Probably (better be!!) a pointer constant "C" data. */
3146 size = sizeof (struct Lisp_String);
3147 }
3148 else
3149 {
3150 size = sizeof (struct Lisp_String) + size + 1;
3151 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3152 }
3153 return size;
3154 }
3155
2939 /* recurse arg isn't actually used */ 3156 /* recurse arg isn't actually used */
2940 static int 3157 static int
2941 pure_sizeof (Lisp_Object obj /*, int recurse */) 3158 pure_sizeof (Lisp_Object obj /*, int recurse */)
2942 { 3159 {
2943 int total = 0; 3160 int total = 0;
2951 if (SYMBOLP (obj)) 3168 if (SYMBOLP (obj))
2952 return total; 3169 return total;
2953 3170
2954 switch (XTYPE (obj)) 3171 switch (XTYPE (obj))
2955 { 3172 {
3173
3174 #ifndef LRECORD_STRING
2956 case Lisp_Type_String: 3175 case Lisp_Type_String:
2957 { 3176 {
2958 struct Lisp_String *ptr = XSTRING (obj); 3177 total += pure_string_sizeof (obj);
2959 int size = string_length (ptr);
2960
2961 if (string_data (ptr) !=
2962 (unsigned char *) ptr + sizeof (struct Lisp_String))
2963 {
2964 /* string-data not allocated contiguously.
2965 Probably (better be!!) a pointer constant "C" data. */
2966 size = sizeof (struct Lisp_String);
2967 }
2968 else
2969 {
2970 size = sizeof (struct Lisp_String) + size + 1;
2971 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
2972 }
2973 total += size;
2974 } 3178 }
2975 break; 3179 break;
3180 #endif /* ! LRECORD_STRING */
2976 3181
2977 #ifndef LRECORD_VECTOR 3182 #ifndef LRECORD_VECTOR
2978 case Lisp_Type_Vector: 3183 case Lisp_Type_Vector:
2979 { 3184 {
2980 struct Lisp_Vector *ptr = XVECTOR (obj); 3185 struct Lisp_Vector *ptr = XVECTOR (obj);
2996 goto tail_recurse; 3201 goto tail_recurse;
2997 } 3202 }
2998 #endif /* unused */ 3203 #endif /* unused */
2999 } 3204 }
3000 break; 3205 break;
3001 #endif /* !LRECORD_SYMBOL */ 3206 #endif /* !LRECORD_VECTOR */
3002 3207
3003 case Lisp_Type_Record: 3208 case Lisp_Type_Record:
3004 { 3209 {
3005 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 3210 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3006 CONST struct lrecord_implementation *implementation 3211 CONST struct lrecord_implementation *implementation
3007 = lheader->implementation; 3212 = lheader->implementation;
3008 3213
3214 #ifdef LRECORD_STRING
3215 if (STRINGP (obj))
3216 total += pure_string_sizeof (obj);
3217 else
3218 #endif
3009 if (implementation->size_in_bytes_method) 3219 if (implementation->size_in_bytes_method)
3010 total += ((implementation->size_in_bytes_method) (lheader)); 3220 total += ((implementation->size_in_bytes_method) (lheader));
3011 else 3221 else
3012 total += implementation->static_size; 3222 total += implementation->static_size;
3013 3223
3028 } 3238 }
3029 #endif /* unused */ 3239 #endif /* unused */
3030 } 3240 }
3031 break; 3241 break;
3032 3242
3243 #ifndef LRECORD_CONS
3033 case Lisp_Type_Cons: 3244 case Lisp_Type_Cons:
3034 { 3245 {
3035 struct Lisp_Cons *ptr = XCONS (obj); 3246 struct Lisp_Cons *ptr = XCONS (obj);
3036 total += sizeof (*ptr); 3247 total += sizeof (*ptr);
3037 #if 0 /* unused */ 3248 #if 0 /* unused */
3049 } 3260 }
3050 goto tail_recurse; 3261 goto tail_recurse;
3051 #endif /* unused */ 3262 #endif /* unused */
3052 } 3263 }
3053 break; 3264 break;
3265 #endif
3054 3266
3055 /* Others can't be purified */ 3267 /* Others can't be purified */
3056 default: 3268 default:
3057 abort (); 3269 abort ();
3058 } 3270 }
3063 3275
3064 3276
3065 3277
3066 /* Find all structures not marked, and free them. */ 3278 /* Find all structures not marked, and free them. */
3067 3279
3280 #ifndef LRECORD_VECTOR
3068 static int gc_count_num_vector_used, gc_count_vector_total_size; 3281 static int gc_count_num_vector_used, gc_count_vector_total_size;
3069 static int gc_count_vector_storage; 3282 static int gc_count_vector_storage;
3283 #endif
3070 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size; 3284 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3071 static int gc_count_bit_vector_storage; 3285 static int gc_count_bit_vector_storage;
3072 static int gc_count_num_short_string_in_use; 3286 static int gc_count_num_short_string_in_use;
3073 static int gc_count_string_total_size; 3287 static int gc_count_string_total_size;
3074 static int gc_count_short_string_total_size; 3288 static int gc_count_short_string_total_size;
3210 } 3424 }
3211 } 3425 }
3212 *used = num_used; 3426 *used = num_used;
3213 /* *total = total_size; */ 3427 /* *total = total_size; */
3214 } 3428 }
3429
3430 #ifndef LRECORD_VECTOR
3215 3431
3216 static void 3432 static void
3217 sweep_vectors_1 (Lisp_Object *prev, 3433 sweep_vectors_1 (Lisp_Object *prev,
3218 int *used, int *total, int *storage) 3434 int *used, int *total, int *storage)
3219 { 3435 {
3248 } 3464 }
3249 *used = num_used; 3465 *used = num_used;
3250 *total = total_size; 3466 *total = total_size;
3251 *storage = total_storage; 3467 *storage = total_storage;
3252 } 3468 }
3469
3470 #endif /* ! LRECORD_VECTOR */
3253 3471
3254 static void 3472 static void
3255 sweep_bit_vectors_1 (Lisp_Object *prev, 3473 sweep_bit_vectors_1 (Lisp_Object *prev,
3256 int *used, int *total, int *storage) 3474 int *used, int *total, int *storage)
3257 { 3475 {
3420 3638
3421 3639
3422 static void 3640 static void
3423 sweep_conses (void) 3641 sweep_conses (void)
3424 { 3642 {
3425 #define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car) 3643 #ifndef LRECORD_CONS
3426 #define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0) 3644 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3645 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3646 #else /* LRECORD_CONS */
3647 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3648 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3649 #endif /* LRECORD_CONS */
3427 #define ADDITIONAL_FREE_cons(ptr) 3650 #define ADDITIONAL_FREE_cons(ptr)
3428 3651
3429 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons); 3652 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3430 } 3653 }
3431 3654
3675 3898
3676 if (BIG_STRING_FULLSIZE_P (fullsize)) 3899 if (BIG_STRING_FULLSIZE_P (fullsize))
3677 abort (); 3900 abort ();
3678 3901
3679 /* Just skip it if it isn't marked. */ 3902 /* Just skip it if it isn't marked. */
3903 #ifdef LRECORD_STRING
3904 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3905 #else
3680 if (!XMARKBIT (string->plist)) 3906 if (!XMARKBIT (string->plist))
3907 #endif
3681 { 3908 {
3682 from_pos += fullsize; 3909 from_pos += fullsize;
3683 continue; 3910 continue;
3684 } 3911 }
3685 3912
3756 sweep_strings (void) 3983 sweep_strings (void)
3757 { 3984 {
3758 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0; 3985 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3759 int debug = debug_string_purity; 3986 int debug = debug_string_purity;
3760 3987
3761 #define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist) 3988 #ifdef LRECORD_STRING
3762 #define UNMARK_string(ptr) \ 3989
3990 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3991 # define UNMARK_string(ptr) \
3992 do { struct Lisp_String *p = (ptr); \
3993 int size = string_length (p); \
3994 UNMARK_RECORD_HEADER (&(p->lheader)); \
3995 num_bytes += size; \
3996 if (!BIG_STRING_SIZE_P (size)) \
3997 { num_small_bytes += size; \
3998 num_small_used++; \
3999 } \
4000 if (debug) debug_string_purity_print (p); \
4001 } while (0)
4002 # define ADDITIONAL_FREE_string(p) \
4003 do { int size = string_length (p); \
4004 if (BIG_STRING_SIZE_P (size)) \
4005 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4006 } while (0)
4007
4008 #else
4009
4010 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4011 # define UNMARK_string(ptr) \
3763 do { struct Lisp_String *p = (ptr); \ 4012 do { struct Lisp_String *p = (ptr); \
3764 int size = string_length (p); \ 4013 int size = string_length (p); \
3765 XUNMARK (p->plist); \ 4014 XUNMARK (p->plist); \
3766 num_bytes += size; \ 4015 num_bytes += size; \
3767 if (!BIG_STRING_SIZE_P (size)) \ 4016 if (!BIG_STRING_SIZE_P (size)) \
3768 { num_small_bytes += size; \ 4017 { num_small_bytes += size; \
3769 num_small_used++; \ 4018 num_small_used++; \
3770 } \ 4019 } \
3771 if (debug) debug_string_purity_print (p); \ 4020 if (debug) debug_string_purity_print (p); \
3772 } while (0) 4021 } while (0)
3773 #define ADDITIONAL_FREE_string(p) \ 4022 # define ADDITIONAL_FREE_string(p) \
3774 do { int size = string_length (p); \ 4023 do { int size = string_length (p); \
3775 if (BIG_STRING_SIZE_P (size)) \ 4024 if (BIG_STRING_SIZE_P (size)) \
3776 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \ 4025 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3777 } while (0) 4026 } while (0)
3778 4027
4028 #endif /* ! LRECORD_STRING */
4029
3779 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String); 4030 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3780 4031
3781 gc_count_num_short_string_in_use = num_small_used; 4032 gc_count_num_short_string_in_use = num_small_used;
3782 gc_count_string_total_size = num_bytes; 4033 gc_count_string_total_size = num_bytes;
3783 gc_count_short_string_total_size = num_small_bytes; 4034 gc_count_short_string_total_size = num_small_bytes;
3786 4037
3787 /* I hate duplicating all this crap! */ 4038 /* I hate duplicating all this crap! */
3788 static int 4039 static int
3789 marked_p (Lisp_Object obj) 4040 marked_p (Lisp_Object obj)
3790 { 4041 {
4042 if (EQ (obj, Qnull_pointer)) return 1;
3791 if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; 4043 if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1;
3792 if (PURIFIED (XPNTR (obj))) return 1; 4044 if (PURIFIED (XPNTR (obj))) return 1;
3793 switch (XGCTYPE (obj)) 4045 switch (XGCTYPE (obj))
3794 { 4046 {
4047 #ifndef LRECORD_CONS
3795 case Lisp_Type_Cons: 4048 case Lisp_Type_Cons:
3796 return XMARKBIT (XCAR (obj)); 4049 return XMARKBIT (XCAR (obj));
4050 #endif
3797 case Lisp_Type_Record: 4051 case Lisp_Type_Record:
3798 return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); 4052 return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj));
4053 #ifndef LRECORD_STRING
3799 case Lisp_Type_String: 4054 case Lisp_Type_String:
3800 return XMARKBIT (XSTRING (obj)->plist); 4055 return XMARKBIT (XSTRING (obj)->plist);
4056 #endif /* ! LRECORD_STRING */
3801 #ifndef LRECORD_VECTOR 4057 #ifndef LRECORD_VECTOR
3802 case Lisp_Type_Vector: 4058 case Lisp_Type_Vector:
3803 return XVECTOR_LENGTH (obj) < 0; 4059 return XVECTOR_LENGTH (obj) < 0;
3804 #endif /* !LRECORD_VECTOR */ 4060 #endif /* !LRECORD_VECTOR */
3805 #ifndef LRECORD_SYMBOL 4061 #ifndef LRECORD_SYMBOL
3843 sweep_strings (); 4099 sweep_strings ();
3844 4100
3845 /* Put all unmarked conses on free list */ 4101 /* Put all unmarked conses on free list */
3846 sweep_conses (); 4102 sweep_conses ();
3847 4103
4104 #ifndef LRECORD_VECTOR
3848 /* Free all unmarked vectors */ 4105 /* Free all unmarked vectors */
3849 sweep_vectors_1 (&all_vectors, 4106 sweep_vectors_1 (&all_vectors,
3850 &gc_count_num_vector_used, &gc_count_vector_total_size, 4107 &gc_count_num_vector_used, &gc_count_vector_total_size,
3851 &gc_count_vector_storage); 4108 &gc_count_vector_storage);
4109 #endif
3852 4110
3853 /* Free all unmarked bit vectors */ 4111 /* Free all unmarked bit vectors */
3854 sweep_bit_vectors_1 (&all_bit_vectors, 4112 sweep_bit_vectors_1 (&all_bit_vectors,
3855 &gc_count_num_bit_vector_used, 4113 &gc_count_num_bit_vector_used,
3856 &gc_count_bit_vector_total_size, 4114 &gc_count_bit_vector_total_size,
4230 ()) 4488 ())
4231 { 4489 {
4232 Lisp_Object pl = Qnil; 4490 Lisp_Object pl = Qnil;
4233 Lisp_Object ret[6]; 4491 Lisp_Object ret[6];
4234 int i; 4492 int i;
4493 #ifdef LRECORD_VECTOR
4494 int gc_count_vector_total_size;
4495 #endif
4235 4496
4236 if (purify_flag && pure_lossage) 4497 if (purify_flag && pure_lossage)
4237 { 4498 {
4238 return Qnil; 4499 return Qnil;
4239 } 4500 }
4247 || lcrecord_stats[i].instances_on_free_list != 0) 4508 || lcrecord_stats[i].instances_on_free_list != 0)
4248 { 4509 {
4249 char buf [255]; 4510 char buf [255];
4250 CONST char *name = lrecord_implementations_table[i]->name; 4511 CONST char *name = lrecord_implementations_table[i]->name;
4251 int len = strlen (name); 4512 int len = strlen (name);
4513 #ifdef LRECORD_VECTOR
4514 /* save this for the FSFmacs-compatible part of the summary */
4515 if (i == *lrecord_vector[0].lrecord_type_index)
4516 gc_count_vector_total_size =
4517 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4518 #endif
4252 sprintf (buf, "%s-storage", name); 4519 sprintf (buf, "%s-storage", name);
4253 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); 4520 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4254 /* Okay, simple pluralization check for `symbol-value-varalias' */ 4521 /* Okay, simple pluralization check for `symbol-value-varalias' */
4255 if (name[len-1] == 's') 4522 if (name[len-1] == 's')
4256 sprintf (buf, "%ses-freed", name); 4523 sprintf (buf, "%ses-freed", name);
4305 pl = gc_plist_hack ("compiled-functions-free", 4572 pl = gc_plist_hack ("compiled-functions-free",
4306 gc_count_num_compiled_function_freelist, pl); 4573 gc_count_num_compiled_function_freelist, pl);
4307 pl = gc_plist_hack ("compiled-functions-used", 4574 pl = gc_plist_hack ("compiled-functions-used",
4308 gc_count_num_compiled_function_in_use, pl); 4575 gc_count_num_compiled_function_in_use, pl);
4309 4576
4577 #ifndef LRECORD_VECTOR
4310 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl); 4578 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4311 pl = gc_plist_hack ("vectors-total-length", 4579 pl = gc_plist_hack ("vectors-total-length",
4312 gc_count_vector_total_size, pl); 4580 gc_count_vector_total_size, pl);
4313 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl); 4581 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4582 #endif
4314 4583
4315 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl); 4584 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4316 pl = gc_plist_hack ("bit-vectors-total-length", 4585 pl = gc_plist_hack ("bit-vectors-total-length",
4317 gc_count_bit_vector_total_size, pl); 4586 gc_count_bit_vector_total_size, pl);
4318 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl); 4587 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4543 * loadup.el will set to nil at end. */ 4812 * loadup.el will set to nil at end. */
4544 purify_flag = 1; 4813 purify_flag = 1;
4545 pureptr = 0; 4814 pureptr = 0;
4546 pure_lossage = 0; 4815 pure_lossage = 0;
4547 breathing_space = 0; 4816 breathing_space = 0;
4817 #ifndef LRECORD_VECTOR
4548 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */ 4818 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4819 #endif
4549 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */ 4820 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4550 XSETINT (Vgc_message, 0); 4821 XSETINT (Vgc_message, 0);
4551 all_lcrecords = 0; 4822 all_lcrecords = 0;
4552 ignore_malloc_warnings = 1; 4823 ignore_malloc_warnings = 1;
4553 init_string_alloc (); 4824 init_string_alloc ();