Mercurial > hg > xemacs-beta

comparison src/gc.c @ 5178:97eb4942aec8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Mon, 29 Mar 2010 21:28:13 -0500
parents 6c6d78781d59
children 71ee43b8a74d
comparison
equal deleted inserted replaced
5177:b785049378e3 5178:97eb4942aec8
379 count = * (long *) irdata; 379 count = * (long *) irdata;
380 break; 380 break;
381 default: 381 default:
382 stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", 382 stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n",
383 idesc[line].type, line, (long) code); 383 idesc[line].type, line, (long) code);
384 #if defined(USE_KKCC) && defined(DEBUG_XEMACS) 384 #if defined (USE_KKCC) && defined (DEBUG_XEMACS)
385 if (gc_in_progress) 385 if (gc_in_progress)
386 kkcc_backtrace (); 386 kkcc_detailed_backtrace ();
387 #endif 387 #endif
388 #ifdef PDUMP 388 #ifdef PDUMP
389 if (in_pdump) 389 if (in_pdump)
390 pdump_backtrace (); 390 pdump_backtrace ();
391 #endif 391 #endif
434 case XD_LO_LINK: 434 case XD_LO_LINK:
435 return sizeof (Lisp_Object); 435 return sizeof (Lisp_Object);
436 case XD_OPAQUE_PTR: 436 case XD_OPAQUE_PTR:
437 return sizeof (void *); 437 return sizeof (void *);
438 #ifdef NEW_GC 438 #ifdef NEW_GC
439 case XD_LISP_OBJECT_BLOCK_PTR: 439 case XD_INLINE_LISP_OBJECT_BLOCK_PTR:
440 #endif /* NEW_GC */ 440 #endif /* NEW_GC */
441 case XD_BLOCK_PTR: 441 case XD_BLOCK_PTR:
442 { 442 {
443 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); 443 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
444 return val * sizeof (void *); 444 return val * sizeof (void *);
555 for (pos = 0; desc[pos].type != XD_END; pos++) 555 for (pos = 0; desc[pos].type != XD_END; pos++)
556 { 556 {
557 EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); 557 EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj);
558 if (offset == max_offset) 558 if (offset == max_offset)
559 { 559 {
560 #if 0
561 /* This can legitimately happen with gap arrays -- if there are
562 no elements in the array, and the gap size is 0, then both
563 parts of the array will be of size 0 and in the same place. */
560 stderr_out ("Two relocatable elements at same offset?\n"); 564 stderr_out ("Two relocatable elements at same offset?\n");
561 ABORT (); 565 ABORT ();
566 #endif
562 } 567 }
563 else if (offset > max_offset) 568 else if (offset > max_offset)
564 { 569 {
565 max_offset = offset; 570 max_offset = offset;
566 max_offset_pos = pos; 571 max_offset_pos = pos;
587 #define GC_CHECK_NOT_FREE(lheader) \ 592 #define GC_CHECK_NOT_FREE(lheader) \
588 gc_checking_assert (! LRECORD_FREE_P (lheader)); 593 gc_checking_assert (! LRECORD_FREE_P (lheader));
589 #else /* not NEW_GC */ 594 #else /* not NEW_GC */
590 #define GC_CHECK_NOT_FREE(lheader) \ 595 #define GC_CHECK_NOT_FREE(lheader) \
591 gc_checking_assert (! LRECORD_FREE_P (lheader)); \ 596 gc_checking_assert (! LRECORD_FREE_P (lheader)); \
592 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ 597 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->frob_block_p || \
593 ! ((struct old_lcrecord_header *) lheader)->free) 598 ! (lheader)->free)
594 #endif /* not NEW_GC */ 599 #endif /* not NEW_GC */
595 600
596 #ifdef USE_KKCC 601 #ifdef USE_KKCC
597 /* The following functions implement the new mark algorithm. 602 /* The following functions implement the new mark algorithm.
598 They mark objects according to their descriptions. They 603 They mark objects according to their descriptions. They
609 typedef struct 614 typedef struct
610 { 615 {
611 void *obj; 616 void *obj;
612 const struct memory_description *desc; 617 const struct memory_description *desc;
613 int pos; 618 int pos;
619 int is_lisp;
614 } kkcc_bt_stack_entry; 620 } kkcc_bt_stack_entry;
615 621
616 static kkcc_bt_stack_entry *kkcc_bt; 622 static kkcc_bt_stack_entry *kkcc_bt;
617 static int kkcc_bt_stack_size; 623 static int kkcc_bt_stack_size;
618 static int kkcc_bt_depth = 0; 624 static int kkcc_bt_depth = 0;
630 kkcc_bt_stack_size); 636 kkcc_bt_stack_size);
631 ABORT (); 637 ABORT ();
632 } 638 }
633 } 639 }
634 640
635 void 641 /* Workhorse backtrace function. Not static because may potentially be
636 kkcc_backtrace (void) 642 called from a debugger. */
643
644 void kkcc_backtrace_1 (int size, int detailed);
645 void
646 kkcc_backtrace_1 (int size, int detailed)
637 { 647 {
638 int i; 648 int i;
639 stderr_out ("KKCC mark stack backtrace :\n"); 649 stderr_out ("KKCC mark stack backtrace :\n");
640 for (i = kkcc_bt_depth - 1; i >= 0; i--) 650 for (i = kkcc_bt_depth - 1; i >= kkcc_bt_depth - size && i >= 0; i--)
641 { 651 {
642 Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj); 652 Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj);
643 stderr_out (" [%d]", i); 653 stderr_out (" [%d] ", i);
644 if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type) 654 if (!kkcc_bt[i].is_lisp)
645 || (!LRECORDP (obj)) 655 stderr_out ("non Lisp Object");
646 || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) 656 else if (!LRECORDP (obj))
657 stderr_out ("Lisp Object, non-record");
658 else if (XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type
659 || (!XRECORD_LHEADER_IMPLEMENTATION (obj)))
660 stderr_out ("WARNING! Bad Lisp Object type %d",
661 XRECORD_LHEADER (obj)->type);
662 else
663 stderr_out ("%s", XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
664 if (detailed && kkcc_bt[i].is_lisp)
647 { 665 {
648 stderr_out (" non Lisp Object"); 666 stderr_out (" ");
649 } 667 debug_print (obj);
650 else
651 {
652 stderr_out (" %s",
653 XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
654 } 668 }
655 stderr_out (" (addr: %p, desc: %p, ", 669 stderr_out (" (addr: %p, desc: %p, ",
656 (void *) kkcc_bt[i].obj, 670 (void *) kkcc_bt[i].obj,
657 (void *) kkcc_bt[i].desc); 671 (void *) kkcc_bt[i].desc);
658 if (kkcc_bt[i].pos >= 0) 672 if (kkcc_bt[i].pos >= 0)
663 else if (kkcc_bt[i].pos == -2) 677 else if (kkcc_bt[i].pos == -2)
664 stderr_out ("dirty object)\n"); 678 stderr_out ("dirty object)\n");
665 } 679 }
666 } 680 }
667 681
682 /* Various front ends onto kkcc_backtrace_1(), meant to be called from
683 a debugger.
684
685 The variants are:
686
687 normal vs _full(): Normal displays up to the topmost 100 items on the
688 stack, whereas full displays all items (even if there are thousands)
689
690 _detailed_() vs _short_(): Detailed here means print out the actual
691 Lisp objects on the stack using debug_print() in addition to their type,
692 whereas short means only show the type
693 */
694
695 void
696 kkcc_detailed_backtrace (void)
697 {
698 kkcc_backtrace_1 (100, 1);
699 }
700
701 void kkcc_short_backtrace (void);
702 void
703 kkcc_short_backtrace (void)
704 {
705 kkcc_backtrace_1 (100, 0);
706 }
707
708 void kkcc_detailed_backtrace_full (void);
709 void
710 kkcc_detailed_backtrace_full (void)
711 {
712 kkcc_backtrace_1 (kkcc_bt_depth, 1);
713 }
714
715 void kkcc_short_backtrace_full (void);
716 void
717 kkcc_short_backtrace_full (void)
718 {
719 kkcc_backtrace_1 (kkcc_bt_depth, 0);
720 }
721
722 /* Short versions for ease in calling from a debugger */
723
724 void kbt (void);
725 void
726 kbt (void)
727 {
728 kkcc_detailed_backtrace ();
729 }
730
731 void kbts (void);
732 void
733 kbts (void)
734 {
735 kkcc_short_backtrace ();
736 }
737
738 void kbtf (void);
739 void
740 kbtf (void)
741 {
742 kkcc_detailed_backtrace_full ();
743 }
744
745 void kbtsf (void);
746 void
747 kbtsf (void)
748 {
749 kkcc_short_backtrace_full ();
750 }
751
668 static void 752 static void
669 kkcc_bt_stack_realloc (void) 753 kkcc_bt_stack_realloc (void)
670 { 754 {
671 kkcc_bt_stack_size *= 2; 755 kkcc_bt_stack_size *= 2;
672 kkcc_bt = (kkcc_bt_stack_entry *) 756 kkcc_bt = (kkcc_bt_stack_entry *)
686 kkcc_bt = 0; 770 kkcc_bt = 0;
687 kkcc_bt_stack_size = 0; 771 kkcc_bt_stack_size = 0;
688 } 772 }
689 773
690 static void 774 static void
691 kkcc_bt_push (void *obj, const struct memory_description *desc, 775 kkcc_bt_push (void *obj, const struct memory_description *desc,
692 int level, int pos) 776 int is_lisp DECLARE_KKCC_DEBUG_ARGS)
693 { 777 {
694 kkcc_bt_depth = level; 778 kkcc_bt_depth = level;
695 kkcc_bt[kkcc_bt_depth].obj = obj; 779 kkcc_bt[kkcc_bt_depth].obj = obj;
696 kkcc_bt[kkcc_bt_depth].desc = desc; 780 kkcc_bt[kkcc_bt_depth].desc = desc;
697 kkcc_bt[kkcc_bt_depth].pos = pos; 781 kkcc_bt[kkcc_bt_depth].pos = pos;
782 kkcc_bt[kkcc_bt_depth].is_lisp = is_lisp;
698 kkcc_bt_depth++; 783 kkcc_bt_depth++;
699 if (kkcc_bt_depth >= kkcc_bt_stack_size) 784 if (kkcc_bt_depth >= kkcc_bt_stack_size)
700 kkcc_bt_stack_realloc (); 785 kkcc_bt_stack_realloc ();
701 } 786 }
702 787
703 #else /* not DEBUG_XEMACS */ 788 #else /* not DEBUG_XEMACS */
704 #define kkcc_bt_init() 789 #define kkcc_bt_init()
705 #define kkcc_bt_push(obj, desc, level, pos) 790 #define kkcc_bt_push(obj, desc)
706 #endif /* not DEBUG_XEMACS */ 791 #endif /* not DEBUG_XEMACS */
707 792
708 /* Object memory descriptions are in the lrecord_implementation structure. 793 /* Object memory descriptions are in the lrecord_implementation structure.
709 But copying them to a parallel array is much more cache-friendly. */ 794 But copying them to a parallel array is much more cache-friendly. */
710 const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)]; 795 const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)];
717 void *data; 802 void *data;
718 const struct memory_description *desc; 803 const struct memory_description *desc;
719 #ifdef DEBUG_XEMACS 804 #ifdef DEBUG_XEMACS
720 int level; 805 int level;
721 int pos; 806 int pos;
807 int is_lisp;
722 #endif 808 #endif
723 } kkcc_gc_stack_entry; 809 } kkcc_gc_stack_entry;
724 810
725 811
726 static kkcc_gc_stack_entry *kkcc_gc_stack_ptr; 812 static kkcc_gc_stack_entry *kkcc_gc_stack_ptr;
792 } 878 }
793 xfree_1 (old_ptr); 879 xfree_1 (old_ptr);
794 } 880 }
795 881
796 static void 882 static void
797 #ifdef DEBUG_XEMACS 883 kkcc_gc_stack_push (void *data, const struct memory_description *desc
798 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc, 884 DECLARE_KKCC_DEBUG_ARGS)
799 int level, int pos)
800 #else
801 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc)
802 #endif
803 { 885 {
804 #ifdef NEW_GC 886 #ifdef NEW_GC
805 GC_STAT_ENQUEUED; 887 GC_STAT_ENQUEUED;
806 #endif /* NEW_GC */ 888 #endif /* NEW_GC */
807 if (KKCC_GC_STACK_FULL) 889 if (KKCC_GC_STACK_FULL)
814 kkcc_gc_stack_ptr[kkcc_gc_stack_rear].pos = pos; 896 kkcc_gc_stack_ptr[kkcc_gc_stack_rear].pos = pos;
815 #endif 897 #endif
816 } 898 }
817 899
818 #ifdef DEBUG_XEMACS 900 #ifdef DEBUG_XEMACS
819 #define kkcc_gc_stack_push(data, desc, level, pos) \ 901
820 kkcc_gc_stack_push_1 (data, desc, level, pos) 902 static inline void
821 #else 903 kkcc_gc_stack_push_0 (void *data, const struct memory_description *desc,
822 #define kkcc_gc_stack_push(data, desc, level, pos) \ 904 int is_lisp DECLARE_KKCC_DEBUG_ARGS)
823 kkcc_gc_stack_push_1 (data, desc) 905 {
824 #endif 906 kkcc_gc_stack_push (data, desc KKCC_DEBUG_ARGS);
907 kkcc_gc_stack_ptr[kkcc_gc_stack_rear].is_lisp = is_lisp;
908 }
909
910 static inline void
911 kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc
912 DECLARE_KKCC_DEBUG_ARGS)
913 {
914 kkcc_gc_stack_push_0 (data, desc, 1 KKCC_DEBUG_ARGS);
915 }
916
917 static inline void
918 kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc
919 DECLARE_KKCC_DEBUG_ARGS)
920 {
921 kkcc_gc_stack_push_0 (data, desc, 0 KKCC_DEBUG_ARGS);
922 }
923
924 #else /* not DEBUG_XEMACS */
925
926 static inline void
927 kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc)
928 {
929 kkcc_gc_stack_push (data, desc);
930 }
931
932 static inline void
933 kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc)
934 {
935 kkcc_gc_stack_push (data, desc);
936 }
937
938 #endif /* (not) DEBUG_XEMACS */
825 939
826 static kkcc_gc_stack_entry * 940 static kkcc_gc_stack_entry *
827 kkcc_gc_stack_pop (void) 941 kkcc_gc_stack_pop (void)
828 { 942 {
829 if (KKCC_GC_STACK_EMPTY) 943 if (KKCC_GC_STACK_EMPTY)
843 } 957 }
844 #endif 958 #endif
845 } 959 }
846 960
847 void 961 void
848 #ifdef DEBUG_XEMACS 962 kkcc_gc_stack_push_lisp_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS)
849 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos)
850 #else
851 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj)
852 #endif
853 { 963 {
854 if (XTYPE (obj) == Lisp_Type_Record) 964 if (XTYPE (obj) == Lisp_Type_Record)
855 { 965 {
856 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 966 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
857 const struct memory_description *desc; 967 const struct memory_description *desc;
862 #ifdef NEW_GC 972 #ifdef NEW_GC
863 MARK_GREY (lheader); 973 MARK_GREY (lheader);
864 #else /* not NEW_GC */ 974 #else /* not NEW_GC */
865 MARK_RECORD_HEADER (lheader); 975 MARK_RECORD_HEADER (lheader);
866 #endif /* not NEW_GC */ 976 #endif /* not NEW_GC */
867 kkcc_gc_stack_push ((void *) lheader, desc, level, pos); 977 kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS);
868 } 978 }
869 } 979 }
870 } 980 }
871 981
872 #ifdef NEW_GC 982 #ifdef NEW_GC
873 #ifdef DEBUG_XEMACS 983
874 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ 984 void
875 kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) 985 kkcc_gc_stack_repush_dirty_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS)
876 #else
877 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \
878 kkcc_gc_stack_push_lisp_object_1 (obj)
879 #endif
880
881 void
882 #ifdef DEBUG_XEMACS
883 kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj, int level, int pos)
884 #else
885 kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj)
886 #endif
887 { 986 {
888 if (XTYPE (obj) == Lisp_Type_Record) 987 if (XTYPE (obj) == Lisp_Type_Record)
889 { 988 {
890 struct lrecord_header *lheader = XRECORD_LHEADER (obj); 989 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
891 const struct memory_description *desc; 990 const struct memory_description *desc;
892 GC_STAT_REPUSHED; 991 GC_STAT_REPUSHED;
893 GC_CHECK_LHEADER_INVARIANTS (lheader); 992 GC_CHECK_LHEADER_INVARIANTS (lheader);
894 desc = RECORD_DESCRIPTION (lheader); 993 desc = RECORD_DESCRIPTION (lheader);
895 MARK_GREY (lheader); 994 MARK_GREY (lheader);
896 kkcc_gc_stack_push ((void*) lheader, desc, level, pos); 995 kkcc_gc_stack_push_lisp ((void*) lheader, desc KKCC_DEBUG_ARGS);
897 } 996 }
898 } 997 }
899 #endif /* NEW_GC */ 998 #endif /* NEW_GC */
900 999
901 #ifdef ERROR_CHECK_GC 1000 #ifdef ERROR_CHECK_GC
907 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ 1006 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \
908 GC_CHECK_NOT_FREE (lheader); \ 1007 GC_CHECK_NOT_FREE (lheader); \
909 } \ 1008 } \
910 } while (0) 1009 } while (0)
911 #else 1010 #else
912 #define KKCC_DO_CHECK_FREE(obj, allow_free) 1011 #define KKCC_DO_CHECK_FREE(obj, allow_free) DO_NOTHING
913 #endif 1012 #endif
914 1013
915 #ifdef ERROR_CHECK_GC 1014 static inline void
916 #ifdef DEBUG_XEMACS 1015 mark_object_maybe_checking_free (Lisp_Object obj, int allow_free
917 static void 1016 DECLARE_KKCC_DEBUG_ARGS)
918 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free,
919 int level, int pos)
920 #else
921 static void
922 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free)
923 #endif
924 { 1017 {
925 KKCC_DO_CHECK_FREE (obj, allow_free); 1018 KKCC_DO_CHECK_FREE (obj, allow_free);
926 kkcc_gc_stack_push_lisp_object (obj, level, pos); 1019 kkcc_gc_stack_push_lisp_object (obj KKCC_DEBUG_ARGS);
927 } 1020 }
928
929 #ifdef DEBUG_XEMACS
930 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
931 mark_object_maybe_checking_free_1 (obj, allow_free, level, pos)
932 #else
933 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
934 mark_object_maybe_checking_free_1 (obj, allow_free)
935 #endif
936 #else /* not ERROR_CHECK_GC */
937 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
938 kkcc_gc_stack_push_lisp_object (obj, level, pos)
939 #endif /* not ERROR_CHECK_GC */
940
941 1021
942 /* This function loops all elements of a struct pointer and calls 1022 /* This function loops all elements of a struct pointer and calls
943 mark_with_description with each element. */ 1023 mark_with_description with each element. */
944 static void 1024 static void
945 #ifdef DEBUG_XEMACS 1025 mark_struct_contents (const void *data,
946 mark_struct_contents_1 (const void *data,
947 const struct sized_memory_description *sdesc, 1026 const struct sized_memory_description *sdesc,
948 int count, int level, int pos) 1027 int count DECLARE_KKCC_DEBUG_ARGS)
949 #else
950 mark_struct_contents_1 (const void *data,
951 const struct sized_memory_description *sdesc,
952 int count)
953 #endif
954 { 1028 {
955 int i; 1029 int i;
956 Bytecount elsize; 1030 Bytecount elsize;
957 elsize = lispdesc_block_size (data, sdesc); 1031 elsize = lispdesc_block_size (data, sdesc);
958 1032
959 for (i = 0; i < count; i++) 1033 for (i = 0; i < count; i++)
960 { 1034 {
961 kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description, 1035 kkcc_gc_stack_push_nonlisp (((char *) data) + elsize * i,
962 level, pos); 1036 sdesc->description
963 } 1037 KKCC_DEBUG_ARGS);
964 } 1038 }
965 1039 }
966 #ifdef DEBUG_XEMACS
967 #define mark_struct_contents(data, sdesc, count, level, pos) \
968 mark_struct_contents_1 (data, sdesc, count, level, pos)
969 #else
970 #define mark_struct_contents(data, sdesc, count, level, pos) \
971 mark_struct_contents_1 (data, sdesc, count)
972 #endif
973
974 1040
975 #ifdef NEW_GC 1041 #ifdef NEW_GC
976 /* This function loops all elements of a struct pointer and calls 1042 /* This function loops all elements of a struct pointer and calls
977 mark_with_description with each element. */ 1043 mark_with_description with each element. */
978 static void 1044 static void
979 #ifdef DEBUG_XEMACS 1045 mark_lisp_object_block_contents (const void *data,
980 mark_lisp_object_block_contents_1 (const void *data, 1046 const struct sized_memory_description *sdesc,
981 const struct sized_memory_description *sdesc, 1047 int count DECLARE_KKCC_DEBUG_ARGS)
982 int count, int level, int pos)
983 #else
984 mark_lisp_object_block_contents_1 (const void *data,
985 const struct sized_memory_description *sdesc,
986 int count)
987 #endif
988 { 1048 {
989 int i; 1049 int i;
990 Bytecount elsize; 1050 Bytecount elsize;
991 elsize = lispdesc_block_size (data, sdesc); 1051 elsize = lispdesc_block_size (data, sdesc);
992 1052
1000 GC_CHECK_LHEADER_INVARIANTS (lheader); 1060 GC_CHECK_LHEADER_INVARIANTS (lheader);
1001 desc = sdesc->description; 1061 desc = sdesc->description;
1002 if (! MARKED_RECORD_HEADER_P (lheader)) 1062 if (! MARKED_RECORD_HEADER_P (lheader))
1003 { 1063 {
1004 MARK_GREY (lheader); 1064 MARK_GREY (lheader);
1005 kkcc_gc_stack_push ((void *) lheader, desc, level, pos); 1065 kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS);
1006 } 1066 }
1007 } 1067 }
1008 } 1068 }
1009 } 1069 }
1010 1070
1011 #ifdef DEBUG_XEMACS
1012 #define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \
1013 mark_lisp_object_block_contents_1 (data, sdesc, count, level, pos)
1014 #else
1015 #define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \
1016 mark_lisp_object_block_contents_1 (data, sdesc, count)
1017 #endif
1018 #endif /* not NEW_GC */ 1071 #endif /* not NEW_GC */
1019 1072
1020 /* This function implements the KKCC mark algorithm. 1073 /* This function implements the KKCC mark algorithm.
1021 Instead of calling mark_object, all the alive Lisp_Objects are pushed 1074 Instead of calling mark_object, all the alive Lisp_Objects are pushed
1022 on the kkcc_gc_stack. This function processes all elements on the stack 1075 on the kkcc_gc_stack. This function processes all elements on the stack
1039 { 1092 {
1040 data = stack_entry->data; 1093 data = stack_entry->data;
1041 desc = stack_entry->desc; 1094 desc = stack_entry->desc;
1042 #ifdef DEBUG_XEMACS 1095 #ifdef DEBUG_XEMACS
1043 level = stack_entry->level + 1; 1096 level = stack_entry->level + 1;
1097 kkcc_bt_push (data, desc, stack_entry->is_lisp, stack_entry->level,
1098 stack_entry->pos);
1099 #else
1100 kkcc_bt_push (data, desc);
1044 #endif 1101 #endif
1045 kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos);
1046 1102
1047 #ifdef NEW_GC 1103 #ifdef NEW_GC
1048 /* Mark black if object is currently grey. This first checks, 1104 /* Mark black if object is currently grey. This first checks,
1049 if the object is really allocated on the mc-heap. If it is, 1105 if the object is really allocated on the mc-heap. If it is,
1050 it can be marked black; if it is not, it cannot be marked. */ 1106 it can be marked black; if it is not, it cannot be marked. */
1091 can be used for untagged pointers. They might be NULL, 1147 can be used for untagged pointers. They might be NULL,
1092 though. */ 1148 though. */
1093 if (EQ (*stored_obj, Qnull_pointer)) 1149 if (EQ (*stored_obj, Qnull_pointer))
1094 break; 1150 break;
1095 #ifdef NEW_GC 1151 #ifdef NEW_GC
1096 mark_object_maybe_checking_free (*stored_obj, 0, level, pos); 1152 mark_object_maybe_checking_free (*stored_obj, 0
1153 KKCC_DEBUG_ARGS);
1097 #else /* not NEW_GC */ 1154 #else /* not NEW_GC */
1098 mark_object_maybe_checking_free 1155 mark_object_maybe_checking_free
1099 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, 1156 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT
1100 level, pos); 1157 KKCC_DEBUG_ARGS);
1101 #endif /* not NEW_GC */ 1158 #endif /* not NEW_GC */
1102 break; 1159 break;
1103 } 1160 }
1104 case XD_LISP_OBJECT_ARRAY: 1161 case XD_LISP_OBJECT_ARRAY:
1105 { 1162 {
1114 1171
1115 if (EQ (*stored_obj, Qnull_pointer)) 1172 if (EQ (*stored_obj, Qnull_pointer))
1116 break; 1173 break;
1117 #ifdef NEW_GC 1174 #ifdef NEW_GC
1118 mark_object_maybe_checking_free 1175 mark_object_maybe_checking_free
1119 (*stored_obj, 0, level, pos); 1176 (*stored_obj, 0 KKCC_DEBUG_ARGS);
1120 #else /* not NEW_GC */ 1177 #else /* not NEW_GC */
1121 mark_object_maybe_checking_free 1178 mark_object_maybe_checking_free
1122 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, 1179 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT
1123 level, pos); 1180 KKCC_DEBUG_ARGS);
1124 #endif /* not NEW_GC */ 1181 #endif /* not NEW_GC */
1125 } 1182 }
1126 break; 1183 break;
1127 } 1184 }
1128 #ifdef NEW_GC 1185 #ifdef NEW_GC
1129 case XD_LISP_OBJECT_BLOCK_PTR: 1186 case XD_INLINE_LISP_OBJECT_BLOCK_PTR:
1130 { 1187 {
1131 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, 1188 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
1132 data); 1189 data);
1133 const struct sized_memory_description *sdesc = 1190 const struct sized_memory_description *sdesc =
1134 lispdesc_indirect_description (data, desc1->data2.descr); 1191 lispdesc_indirect_description (data, desc1->data2.descr);
1135 const char *dobj = * (const char **) rdata; 1192 const char *dobj = * (const char **) rdata;
1136 if (dobj) 1193 if (dobj)
1137 mark_lisp_object_block_contents 1194 mark_lisp_object_block_contents
1138 (dobj, sdesc, count, level, pos); 1195 (dobj, sdesc, count KKCC_DEBUG_ARGS);
1139 break; 1196 break;
1140 } 1197 }
1141 #endif /* NEW_GC */ 1198 #endif /* NEW_GC */
1142 case XD_BLOCK_PTR: 1199 case XD_BLOCK_PTR:
1143 { 1200 {
1145 data); 1202 data);
1146 const struct sized_memory_description *sdesc = 1203 const struct sized_memory_description *sdesc =
1147 lispdesc_indirect_description (data, desc1->data2.descr); 1204 lispdesc_indirect_description (data, desc1->data2.descr);
1148 const char *dobj = * (const char **) rdata; 1205 const char *dobj = * (const char **) rdata;
1149 if (dobj) 1206 if (dobj)
1150 mark_struct_contents (dobj, sdesc, count, level, pos); 1207 mark_struct_contents (dobj, sdesc, count KKCC_DEBUG_ARGS);
1151 break; 1208 break;
1152 } 1209 }
1153 case XD_BLOCK_ARRAY: 1210 case XD_BLOCK_ARRAY:
1154 { 1211 {
1155 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, 1212 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
1156 data); 1213 data);
1157 const struct sized_memory_description *sdesc = 1214 const struct sized_memory_description *sdesc =
1158 lispdesc_indirect_description (data, desc1->data2.descr); 1215 lispdesc_indirect_description (data, desc1->data2.descr);
1159 1216
1160 mark_struct_contents (rdata, sdesc, count, level, pos); 1217 mark_struct_contents (rdata, sdesc, count KKCC_DEBUG_ARGS);
1161 break; 1218 break;
1162 } 1219 }
1163 case XD_UNION: 1220 case XD_UNION:
1164 case XD_UNION_DYNAMIC_SIZE: 1221 case XD_UNION_DYNAMIC_SIZE:
1165 desc1 = lispdesc_process_xd_union (desc1, desc, data); 1222 desc1 = lispdesc_process_xd_union (desc1, desc, data);
1167 goto union_switcheroo; 1224 goto union_switcheroo;
1168 break; 1225 break;
1169 1226
1170 default: 1227 default:
1171 stderr_out ("Unsupported description type : %d\n", desc1->type); 1228 stderr_out ("Unsupported description type : %d\n", desc1->type);
1172 kkcc_backtrace (); 1229 kkcc_detailed_backtrace ();
1173 ABORT (); 1230 ABORT ();
1174 } 1231 }
1175 } 1232 }
1176 1233
1177 #ifdef NEW_GC 1234 #ifdef NEW_GC
1390 rest = rest->next; 1447 rest = rest->next;
1391 } 1448 }
1392 } 1449 }
1393 /* Keep objects alive that need to be finalized by marking 1450 /* Keep objects alive that need to be finalized by marking
1394 Vfinalizers_to_run transitively. */ 1451 Vfinalizers_to_run transitively. */
1395 kkcc_gc_stack_push_lisp_object (Vfinalizers_to_run, 0, -1); 1452 kkcc_gc_stack_push_lisp_object_0 (Vfinalizers_to_run);
1396 kkcc_marking (0); 1453 kkcc_marking (0);
1397 } 1454 }
1398 1455
1399 void 1456 void
1400 run_finalizers (void) 1457 run_finalizers (void)
1612 #endif /* NEW_GC */ 1669 #endif /* NEW_GC */
1613 1670
1614 /* Mark all the special slots that serve as the roots of accessibility. */ 1671 /* Mark all the special slots that serve as the roots of accessibility. */
1615 1672
1616 #ifdef USE_KKCC 1673 #ifdef USE_KKCC
1617 # define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) 1674 # define mark_object(obj) kkcc_gc_stack_push_lisp_object_0 (obj)
1618 #endif /* USE_KKCC */ 1675 #endif /* USE_KKCC */
1619 1676
1620 { /* staticpro() */ 1677 { /* staticpro() */
1621 Lisp_Object **p = Dynarr_begin (staticpros); 1678 Lisp_Object **p = Dynarr_begin (staticpros);
1622 Elemcount len = Dynarr_length (staticpros); 1679 Elemcount len = Dynarr_length (staticpros);
1772 gc_finish (void) 1829 gc_finish (void)
1773 { 1830 {
1774 #ifdef NEW_GC 1831 #ifdef NEW_GC
1775 GC_SET_PHASE (FINISH_GC); 1832 GC_SET_PHASE (FINISH_GC);
1776 #endif /* NEW_GC */ 1833 #endif /* NEW_GC */
1834 finish_object_memory_usage_stats ();
1777 consing_since_gc = 0; 1835 consing_since_gc = 0;
1778 #ifndef DEBUG_XEMACS 1836 #ifndef DEBUG_XEMACS
1779 /* Allow you to set it really fucking low if you really want ... */ 1837 /* Allow you to set it really fucking low if you really want ... */
1780 if (gc_cons_threshold < 10000) 1838 if (gc_cons_threshold < 10000)
1781 gc_cons_threshold = 10000; 1839 gc_cons_threshold = 10000;