CVS update by crestani xemacs/src, buffer.c, console-gtk-impl.h, console-stream-impl.h, console-stream.h, console-x-impl.h, device-msw.c, dumper.c, event-msw.c, frame-gtk.c, glyphs.h, objects-tty-impl.h, specifier.c ...

User: crestani Date: 05/11/25 02:42:26 Modified: xemacs/src .cvsignore ChangeLog Makefile.in.in alloc.c buffer.c buffer.h bytecode.c bytecode.h config.h.in console-gtk-impl.h console-msw-impl.h console-stream-impl.h console-stream.c console-stream.h console-tty-impl.h console-tty.c console-x-impl.h console.c depend device-gtk.c device-msw.c device-tty.c device-x.c device.c dumper.c dynarr.c elhash.c elhash.h emacs.c eval.c event-msw.c events.c extents.c extents.h faces.h frame-gtk.c frame-msw.c frame-x.c frame.c glyphs.c glyphs.h lisp.h lrecord.h mc-alloc.c mc-alloc.h objects-tty-impl.h objects-tty.c objects.c print.c specifier.c specifier.h syntax.c syntax.h window.c Added: xemacs/src .dbxrc.in .gdbinit.in gc.c gc.h vdb-fake.c vdb-mach.c vdb-posix.c vdb-win32.c vdb.c vdb.h Removed: xemacs/src .dbxrc .gdbinit Log: Incremental Garbage Collector Revision Changes Path 1.473 +9 -0 XEmacs/xemacs/ChangeLog Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/ChangeLog,v retrieving revision 1.472 retrieving revision 1.473 diff -u -p -r1.472 -r1.473 --- ChangeLog 2005/11/22 07:14:47 1.472 +++ ChangeLog 2005/11/25 01:41:31 1.473 ＠＠ -1,3 +1,12 ＠＠ +2005-11-21 Marcus Crestani <crestani(a)xemacs.org&gt; + + Incremental Garbage Collector + + * configure.ac: Add newgc option; if newgc, turn on kkcc and + mc-alloc. Add checks for write barrier, determine which write + barrier to use. Add vdb option to override write barrier + auto-detection. Generate .gdbinit and .dbxrc. + 2005-11-22 Ben Wing <ben(a)xemacs.org&gt; * dynodump/Makefile.in.in (mostlyclean): 1.261 +900 -6 XEmacs/xemacs/configure Index: configure =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/configure,v retrieving revision 1.260 retrieving revision 1.261 diff -u -p -r1.260 -r1.261 --- configure 2005/11/16 11:53:47 1.260 +++ configure 2005/11/25 01:41:32 1.261 ＠＠ -1154,6 +1154,14 ＠＠ Memory allocation options with `mc-alloc'). --with-kkcc Enable experimental new GC algorithms. --with-mc-alloc Enable experimental new allocator. + --with-newgc Enable new incremental garbage collector. + --with-vdb=TYPE Override auto-detection of virtual-dirty-bit + write-barrier implementation for the new garbage + collector. TYPE must be one of "auto" (for + auto-detection), "posix", "win32", "mach", or "fake" + (uses the new garbage collector but disables + incremental collections). The default is to use + auto-detection. Emacs Lisp options ------------------ ＠＠ -3366,7 +3374,106 ＠＠ if test "${with_mc_alloc+set}" = set; th else enable_mc_alloc=yes fi; +# If --with-newgc or --without-newgc were given then copy the value to the +# equivalent enable_newgc variable. +if test "${with_newgc+set}" = set; then + enable_newgc="$with_newgc" +fi; +# If -enable-newgc or --disable-newgc were given then copy the value to the +# equivalent with_newgc variable. +if test "${enable_newgc+set}" = set; then + with_newgc="$enable_newgc" +fi; +# Check whether --with-newgc or --without-newgc was given. +if test "${with_newgc+set}" = set; then + enableval="$with_newgc" + withval="$with_newgc" + +fi; +_vdb_notfirst="" +with_vdb_auto= +enable_vdb_auto= +with_vdb_posix= +enable_vdb_posix= +with_vdb_win32= +enable_vdb_win32= +with_vdb_mach= +enable_vdb_mach= +with_vdb_fake= +enable_vdb_fake= +with_vdb_no= +enable_vdb_no= + +_vdb_types="auto posix win32 mach fake no" +_vdb_default="auto,posix,win32,mach,fake,no" + + +# If --with-vdb or --without-vdb were given then copy the value to the +# equivalent enable_vdb variable. +if test "${with_vdb+set}" = set; then + enable_vdb="$with_vdb" +fi; +# If -enable-vdb or --disable-vdb were given then copy the value to the +# equivalent with_vdb variable. +if test "${enable_vdb+set}" = set; then + with_vdb="$enable_vdb" +fi; +# Check whether --with-vdb or --without-vdb was given. +if test "${with_vdb+set}" = set; then + enableval="$with_vdb" + withval="$with_vdb" + for y in $_vdb_types; do + eval "with_vdb_$y=no" + eval "enable_vdb_$y=no" +done +for x in `echo "$with_vdb" | sed -e 's/,/ /g'` ; do + _vdb_all_default="" + _vdb_found="" + case "$x" in + n | no | non | none ) _vdb_all_default=no ;; + a | al | all | both ) _vdb_all_default=yes ;; + esac + + if test -z "$_vdb_all_default"; then + for y in $_vdb_types; do + if test "$x" = "$y"; then + _vdb_found=yes + eval "with_vdb_$y=yes" + eval "enable_vdb_$y=yes" + elif test "$x" = "no$y"; then + _vdb_found=yes + eval "with_vdb_$y=no" + eval "enable_vdb_$y=no" + fi + done + test -z "$_vdb_found" && _vdb_bogus=yes + fi + if test "$_vdb_bogus" = "yes" -o \ + \( -n "$_vdb_all_default" -a -n "$_vdb_notfirst" \) ; then + (echo "$progname: Usage error:" +echo " " "Valid values for the --with-vdb option are: +$_vdb_types. With prefix \"no\", switch it off. +Defaults may be overridden with \`all' or \`none' first in the list. +Hardcoded default is: $_vdb_default." +echo " Use \`$progname --help' to show usage.") >&2 && exit 1 + elif test -n "$_vdb_all_default" ; then + for y in $_vdb_types; do + eval "with_vdb_$y=$_vdb_all_default" + eval "enable_vdb_$y=$_vdb_all_default" + done + fi + _vdb_notfirst=yes +done +unset _vdb_bogus _vdb_found _vdb_notfirst _vdb_types +unset _vdb_default _vdb_all_default x y + + + +else + enable_vdb="auto" +fi; + # If --with-modules or --without-modules were given then copy the value to the # equivalent enable_modules variable. if test "${with_modules+set}" = set; then ＠＠ -4431,6 +4538,38 ＠＠ if test -z "$enable_pdump"; then esac fi +if test "$enable_newgc" = "yes"; then + if test "$enable_vdb" = "auto"; then + case "$opsys" in + darwin ) cat >>confdefs.h <<\_ACEOF +#define VDB_MACH 1 +_ACEOF + have_vdb_mach=yes ;; + cygwin* ) cat >>confdefs.h <<\_ACEOF +#define VDB_WIN32 1 +_ACEOF + have_vdb_win32=yes ;; + linux* ) check_vdb_posix=yes ;; + freebsd ) check_vdb_posix=yes ;; + * ) check_vdb_posix=yes ;; + esac + else + case "$enable_vdb" in + mach ) cat >>confdefs.h <<\_ACEOF +#define VDB_MACH 1 +_ACEOF + have_vdb_mach=yes ;; + win32 ) cat >>confdefs.h <<\_ACEOF +#define VDB_WIN32 1 +_ACEOF + have_vdb_win32=yes ;; + posix ) check_vdb_posix=yes ;; + fake ) have_vdb_fake=yes ;; + no ) have_vdb_fake=yes ;; + esac + fi +fi + if test -z "$with_dynamic"; then case "$opsys" in hpux* | sunos4* ) with_dynamic=no ;; ＠＠ -8630,6 +8769,11 ＠＠ if test -z "$enable_dump_in_exec"; then fi fi +if test "$enable_newgc" = "yes"; then + enable_mc_alloc=yes + enable_kkcc=yes +fi + test "$verbose" = "yes" && \ for var in libs_machine libs_system libs_termcap libs_standard objects_machine objects_system c_switch_machine c_switch_system ld_switch_machine ld_switch_system unexec ld_switch_shared ld lib_gcc ld_text_start_addr start_files ordinary_link have_terminfo mail_use_flock mail_use_lockf; do eval "echo \"$var = '\$$var'\""; done && echo "" ＠＠ -28581,14 +28725,662 ＠＠ echo "$as_me: WARNING: Use of getaddrinf esac fi +if test "$check_vdb_posix" = "yes" ; then + echo "$as_me:$LINENO: checking for mprotect" >&5 +echo $ECHO_N "checking for mprotect... $ECHO_C" >&6 +if test "${ac_cv_func_mprotect+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define mprotect to an innocuous variant, in case <limits.h> declares mprotect. + For example, HP-UX 11i <limits.h> declares gettimeofday. */ +#define mprotect innocuous_mprotect + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char mprotect (); below. + Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + <limits.h> exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif + +#undef mprotect + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char mprotect (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_mprotect) || defined (__stub___mprotect) +choke me +#else +char (*f) () = mprotect; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != mprotect; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_mprotect=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_mprotect=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_mprotect" >&5 +echo "${ECHO_T}$ac_cv_func_mprotect" >&6 +if test $ac_cv_func_mprotect = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_MPROTECT 1 +_ACEOF + have_vdb_mprotect=yes +fi + + + echo "$as_me:$LINENO: checking for sigaction" >&5 +echo $ECHO_N "checking for sigaction... $ECHO_C" >&6 +if test "${ac_cv_func_sigaction+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define sigaction to an innocuous variant, in case <limits.h> declares sigaction. + For example, HP-UX 11i <limits.h> declares gettimeofday. */ +#define sigaction innocuous_sigaction + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char sigaction (); below. + Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + <limits.h> exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif + +#undef sigaction + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char sigaction (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_sigaction) || defined (__stub___sigaction) +choke me +#else +char (*f) () = sigaction; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != sigaction; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_sigaction=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_sigaction=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_sigaction" >&5 +echo "${ECHO_T}$ac_cv_func_sigaction" >&6 +if test $ac_cv_func_sigaction = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_SIGACTION 1 +_ACEOF + have_vdb_sigaction=yes +else + have_vdb_sigaction=no +fi + + echo "$as_me:$LINENO: checking for struct siginfo.si_addr" >&5 +echo $ECHO_N "checking for struct siginfo.si_addr... $ECHO_C" >&6 +if test "${ac_cv_member_struct_siginfo_si_addr+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> + +int +main () +{ +static struct siginfo ac_aggr; +if (ac_aggr.si_addr) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_siginfo_si_addr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> + +int +main () +{ +static struct siginfo ac_aggr; +if (sizeof ac_aggr.si_addr) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_siginfo_si_addr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_member_struct_siginfo_si_addr=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_member_struct_siginfo_si_addr" >&5 +echo "${ECHO_T}$ac_cv_member_struct_siginfo_si_addr" >&6 +if test $ac_cv_member_struct_siginfo_si_addr = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_STRUCT_SIGINFO_SI_ADDR 1 +_ACEOF + have_si_addr=yes +fi + + echo "$as_me:$LINENO: checking for siginfo_t.si_addr" >&5 +echo $ECHO_N "checking for siginfo_t.si_addr... $ECHO_C" >&6 +if test "${ac_cv_member_siginfo_t_si_addr+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> + +int +main () +{ +static siginfo_t ac_aggr; +if (ac_aggr.si_addr) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_siginfo_t_si_addr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> + +int +main () +{ +static siginfo_t ac_aggr; +if (sizeof ac_aggr.si_addr) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_siginfo_t_si_addr=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_member_siginfo_t_si_addr=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_member_siginfo_t_si_addr" >&5 +echo "${ECHO_T}$ac_cv_member_siginfo_t_si_addr" >&6 +if test $ac_cv_member_siginfo_t_si_addr = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_SIGINFO_T_SI_ADDR 1 +_ACEOF + have_si_addr=yes +fi + + if test "$have_si_addr" != "yes" ; then + have_vdb_sigaction=no + fi + + echo "$as_me:$LINENO: checking for signal" >&5 +echo $ECHO_N "checking for signal... $ECHO_C" >&6 +if test "${ac_cv_func_signal+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define signal to an innocuous variant, in case <limits.h> declares signal. + For example, HP-UX 11i <limits.h> declares gettimeofday. */ +#define signal innocuous_signal +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char signal (); below. + Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + <limits.h> exists even on freestanding compilers. */ +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif +#undef signal +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char signal (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_signal) || defined (__stub___signal) +choke me +#else +char (*f) () = signal; +#endif +#ifdef __cplusplus +} +#endif +int +main () +{ +return f != signal; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_signal=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 +ac_cv_func_signal=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_signal" >&5 +echo "${ECHO_T}$ac_cv_func_signal" >&6 +if test $ac_cv_func_signal = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_SIGNAL 1 +_ACEOF + have_vdb_signal=yes +fi + echo "$as_me:$LINENO: checking for struct sigcontext.cr2" >&5 +echo $ECHO_N "checking for struct sigcontext.cr2... $ECHO_C" >&6 +if test "${ac_cv_member_struct_sigcontext_cr2+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> +int +main () +{ +static struct sigcontext ac_aggr; +if (ac_aggr.cr2) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_sigcontext_cr2=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <signal.h> + +int +main () +{ +static struct sigcontext ac_aggr; +if (sizeof ac_aggr.cr2) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_member_struct_sigcontext_cr2=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_member_struct_sigcontext_cr2=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_member_struct_sigcontext_cr2" >&5 +echo "${ECHO_T}$ac_cv_member_struct_sigcontext_cr2" >&6 +if test $ac_cv_member_struct_sigcontext_cr2 = yes; then + cat >>confdefs.h <<\_ACEOF +#define HAVE_STRUCT_SIGCONTEXT_CR2 1 +_ACEOF + have_cr2=yes +fi + + + if test "$have_cr2" != "yes" ; then + have_vdb_signal=no + fi + + if test "$have_vdb_mprotect" != "yes" ; then + have_vdb_sigaction=no + have_vdb_signal=no + fi + + if test "$have_vdb_sigaction" != "yes" -a "$have_vdb_signal" != "yes" ; then + have_vdb_posix=no + have_vdb_fake=yes + else + have_vdb_posix=yes + have_vdb_fake=no + fi +fi + + + + + + + + + for ac_func in getpt _getpty grantpt unlockpt ptsname killpg tcgetpgrp do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` ＠＠ -37220,14 +38012,14 ＠＠ if test "$verbose" = "yes"; then fi -if test -f "$srcdir/src/.gdbinit" -a ! -f "src/.gdbinit"; then - test "$verbose" = "yes" && echo "creating src/.gdbinit" - echo "source $srcdir/src/.gdbinit" > "src/.gdbinit" +if test -f "$srcdir/src/.gdbinit.in" -a ! -f "src/.gdbinit.in"; then + test "$verbose" = "yes" && echo "creating src/.gdbinit.in" + echo "source $srcdir/src/.gdbinit.in" > "src/.gdbinit.in" fi -if test -f "$srcdir/src/.dbxrc" -a ! -f "src/.dbxrc"; then - test "$verbose" = "yes" && echo "creating src/.dbxrc" - echo ". $srcdir/src/.dbxrc" > "src/.dbxrc" +if test -f "$srcdir/src/.dbxrc.in" -a ! -f "src/.dbxrc.in"; then + test "$verbose" = "yes" && echo "creating src/.dbxrc.in" + echo ". $srcdir/src/.dbxrc.in" > "src/.dbxrc.in" fi if test -f "$srcdir/TAGS" -a ! -f "TAGS"; then ＠＠ -37529,6 +38321,18 ＠＠ test "$enable_mc_alloc" = "yes" && ca #define MC_ALLOC 1 _ACEOF +test "$enable_newgc" = "yes" && cat >>confdefs.h <<\_ACEOF +#define NEW_GC 1 +_ACEOF + +test "$have_vdb_posix" = "yes" && cat >>confdefs.h <<\_ACEOF +#define VDB_POSIX 1 +_ACEOF + +test "$have_vdb_fake" = "yes" && cat >>confdefs.h <<\_ACEOF +#define VDB_FAKE 1 +_ACEOF + test "$enable_quick_build" = "yes" && cat >>confdefs.h <<\_ACEOF #define QUICK_BUILD 1 _ACEOF ＠＠ -37830,6 +38634,32 ＠＠ if test "$enable_mc_alloc" = yes ; then echo " WARNING: turn it off." echo " WARNING: ---------------------------------------------------------" fi +test "$enable_newgc" = yes && echo " Using the new incremental garbage collector." +if test "$have_vdb_posix" = yes ; then + if test "$have_vdb_sigaction" = yes ; then + echo " Using POSIX sigaction() to install fault handler." + else + echo " Using POSIX signal() to install vdb fault handler." + fi +fi +if test "$have_vdb_win32" = yes ; then + echo " Using special WIN32 vdb fault handler." +fi +if test "$have_vdb_mach" = yes ; then + echo " Using mach exception mechanism as vdb fault handler." +fi +if test "$have_vdb_fake" = yes && test "$enable_vdb" != fake; then + echo " WARNING: ---------------------------------------------------------" + echo " WARNING: The new incremental garbage collector is enabled, but" + echo " WARNING: a virtual dirty bit implementation is not yet available" + echo " WARNING: on this system. XEmacs will crash if you try to switch on" + echo " WARNUNG: incremental garbage collection!" + echo " WARNING: Use \`--disable-newgc' to turn incremental gc off." + echo " WARNING: ---------------------------------------------------------" +fi +if test "$have_vdb_fake" = yes && test "$enable_vdb" == fake; then + echo " Virtual dirty bit write barrier manually disabled." +fi test "$enable_pdump" = yes && echo " Using the new portable dumper." test "$enable_dump_in_exec" = yes && echo " Dumping into executable." test "$enable_debug" = yes && echo " Compiling in support for extra debugging code." ＠＠ -39254,6 +40084,70 ＠＠ $CPP -I. -I${srcdir}/src -DUSE_GNU_MAKE chmod 444 Makefile.new mv -f Makefile.new GNUmakefile + if test -r ".gdbinit.in"; then + rm -f junk.c + < .gdbinit.in \ + sed -e '/^# Generated/d' \ + -e 's%/\*\*/#.*%%' \ + -e 's/^ *# */#/' \ + -e '/^##/d' \ + -e '/^#/ { +p +d +}' \ + -e '/./ { +s/\([\"]\)/\\\1/g +s/^/"/ +s/$/"/ +}' > junk.c; + + echo creating $dir/.gdbinit +$CPP -I. -I${srcdir}/src junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ TAB][ TAB]*$//'\ + -e 's/^ / /' \ + -e '/^[ ]*$/d' \ + -e '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ TAB]*\"// + s/\"[ TAB]*$// +}' > Makefile.new + chmod 444 Makefile.new + mv -f Makefile.new .gdbinit + + fi + if test -r ".dbxrc.in"; then + rm -f junk.c + < .dbxrc.in \ + sed -e '/^# Generated/d' \ + -e 's%/\*\*/#.*%%' \ + -e 's/^ *# */#/' \ + -e '/^##/d' \ + -e '/^#/ { +p +d +}' \ + -e '/./ { +s/\([\"]\)/\\\1/g +s/^/"/ +s/$/"/ +}' > junk.c; + + echo creating $dir/.dbxrc +$CPP -I. -I${srcdir}/src junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ TAB][ TAB]*$//'\ + -e 's/^ / /' \ + -e '/^[ ]*$/d' \ + -e '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ TAB]*\"// + s/\"[ TAB]*$// +}' > Makefile.new + chmod 444 Makefile.new + mv -f Makefile.new .dbxrc + + fi if test -r "xemacs.def.in"; then rm -f junk.c cp xemacs.def.in junk.c 1.22 +126 -6 XEmacs/xemacs/configure.ac Index: configure.ac =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/configure.ac,v retrieving revision 1.21 retrieving revision 1.22 diff -u -p -r1.21 -r1.22 --- configure.ac 2005/11/16 11:53:53 1.21 +++ configure.ac 2005/11/25 01:41:36 1.22 ＠＠ -875,6 +875,18 ＠＠ XE_MERGED_ARG([kkcc], XE_MERGED_ARG([mc-alloc], AC_HELP_STRING([--enable-mc-alloc],[Enable experimental new allocator.]), [], [enable_mc_alloc=yes]) +XE_MERGED_ARG([newgc], + AC_HELP_STRING([--enable-newgc],[Enable new incremental garbage collector.]), + [], []) +XE_COMPLEX_ARG([vdb], + AC_HELP_STRING([--enable-vdb=TYPE],[Override auto-detection of + virtual-dirty-bit write-barrier implementation for the + new garbage collector. TYPE must be one of "auto" (for + auto-detection), "posix", "win32", "mach", or "fake" + (uses the new garbage collector but disables + incremental collections). The default is to + use auto-detection.]), + [], [enable_vdb="auto"],[auto,posix,win32,mach,fake,no]) dnl XE_HELP_SUBSECTION([Emacs Lisp options]) XE_MERGED_ARG([modules], ＠＠ -1683,6 +1695,29 ＠＠ if test -z "$enable_pdump"; then esac fi +if test "$enable_newgc" = "yes"; then + if test "$enable_vdb" = "auto"; then + case "$opsys" in + darwin ) AC_DEFINE(VDB_MACH) have_vdb_mach=yes ;; + cygwin* ) AC_DEFINE(VDB_WIN32) have_vdb_win32=yes ;; + linux* ) check_vdb_posix=yes ;; + freebsd ) check_vdb_posix=yes ;; +dnl bail out immediately +dnl * ) have_vdb_fake=yes ;; +dnl if not sure, try posix first, maybe we are lucky + * ) check_vdb_posix=yes ;; + esac + else + case "$enable_vdb" in + mach ) AC_DEFINE(VDB_MACH) have_vdb_mach=yes ;; + win32 ) AC_DEFINE(VDB_WIN32) have_vdb_win32=yes ;; + posix ) check_vdb_posix=yes ;; + fake ) have_vdb_fake=yes ;; + no ) have_vdb_fake=yes ;; + esac + fi +fi + if test -z "$with_dynamic"; then case "$opsys" in hpux* | sunos4* ) with_dynamic=no ;; ＠＠ -2044,6 +2079,12 ＠＠ if test -z "$enable_dump_in_exec"; then fi fi +dnl New incremental garbage collector +if test "$enable_newgc" = "yes"; then + enable_mc_alloc=yes + enable_kkcc=yes +fi + dnl For debugging... test "$verbose" = "yes" && \ PRINT_VAR(libs_machine libs_system libs_termcap libs_standard ＠＠ -4431,6 +4472,48 ＠＠ if test "$ac_cv_func_getaddrinfo" != "no esac fi +dnl check for vdb-related stuff +if test "$check_vdb_posix" = "yes" ; then + dnl no mprotect, no vdb + AC_CHECK_FUNC(mprotect,AC_DEFINE(HAVE_MPROTECT) have_vdb_mprotect=yes,) + + dnl sigaction needs either struct siginfo or siginfo_t + AC_CHECK_FUNC(sigaction, AC_DEFINE(HAVE_SIGACTION) have_vdb_sigaction=yes, + have_vdb_sigaction=no) + AC_CHECK_MEMBER(struct siginfo.si_addr, + AC_DEFINE(HAVE_STRUCT_SIGINFO_SI_ADDR) have_si_addr=yes,, + [#include <signal.h>]) + AC_CHECK_MEMBER(siginfo_t.si_addr, + AC_DEFINE(HAVE_SIGINFO_T_SI_ADDR) have_si_addr=yes,, + [#include <signal.h>]) + if test "$have_si_addr" != "yes" ; then + have_vdb_sigaction=no + fi + + dnl signal needs struct sigcontext + AC_CHECK_FUNC(signal, AC_DEFINE(HAVE_SIGNAL) have_vdb_signal=yes,) + AC_CHECK_MEMBER(struct sigcontext.cr2, + AC_DEFINE(HAVE_STRUCT_SIGCONTEXT_CR2) have_cr2=yes,, + [#include <signal.h>]) + + if test "$have_cr2" != "yes" ; then + have_vdb_signal=no + fi + + if test "$have_vdb_mprotect" != "yes" ; then + have_vdb_sigaction=no + have_vdb_signal=no + fi + + if test "$have_vdb_sigaction" != "yes" -a "$have_vdb_signal" != "yes" ; then + have_vdb_posix=no + have_vdb_fake=yes + else + have_vdb_posix=yes + have_vdb_fake=no + fi +fi + dnl ---------------------------------------------------------------- dnl Check for Unixoid pty/process support. dnl ---------------------------------------------------------------- ＠＠ -5318,15 +5401,15 ＠＠ dnl Create some auxiliary files for deve dnl ---------------------------------------------- dnl Create a .gdbinit useful for debugging XEmacs -if test -f "$srcdir/src/.gdbinit" -a ! -f "src/.gdbinit"; then - test "$verbose" = "yes" && echo "creating src/.gdbinit" - echo "source $srcdir/src/.gdbinit" > "src/.gdbinit" +if test -f "$srcdir/src/.gdbinit.in" -a ! -f "src/.gdbinit.in"; then + test "$verbose" = "yes" && echo "creating src/.gdbinit.in" + echo "source $srcdir/src/.gdbinit.in" > "src/.gdbinit.in" fi dnl Create a .dbxrc useful for debugging XEmacs -if test -f "$srcdir/src/.dbxrc" -a ! -f "src/.dbxrc"; then - test "$verbose" = "yes" && echo "creating src/.dbxrc" - echo ". $srcdir/src/.dbxrc" > "src/.dbxrc" +if test -f "$srcdir/src/.dbxrc.in" -a ! -f "src/.dbxrc.in"; then + test "$verbose" = "yes" && echo "creating src/.dbxrc.in" + echo ". $srcdir/src/.dbxrc.in" > "src/.dbxrc.in" fi dnl Create a useful TAGS file ＠＠ -5584,6 +5667,9 ＠＠ test "$GCC" = "yes" && AC test "$enable_external_widget" = "yes" && AC_DEFINE(EXTERNAL_WIDGET) test "$enable_kkcc" = "yes" && AC_DEFINE(USE_KKCC) test "$enable_mc_alloc" = "yes" && AC_DEFINE(MC_ALLOC) +test "$enable_newgc" = "yes" && AC_DEFINE(NEW_GC) +test "$have_vdb_posix" = "yes" && AC_DEFINE(VDB_POSIX) +test "$have_vdb_fake" = "yes" && AC_DEFINE(VDB_FAKE) test "$enable_quick_build" = "yes" && AC_DEFINE(QUICK_BUILD) test "$with_purify" = "yes" && AC_DEFINE(PURIFY) test "$with_quantify" = "yes" && AC_DEFINE(QUANTIFY) ＠＠ -5864,6 +5950,32 ＠＠ if test "$enable_mc_alloc" = yes ; then echo " WARNING: turn it off." echo " WARNING: ---------------------------------------------------------" fi +test "$enable_newgc" = yes && echo " Using the new incremental garbage collector." +if test "$have_vdb_posix" = yes ; then + if test "$have_vdb_sigaction" = yes ; then + echo " Using POSIX sigaction() to install fault handler." + else + echo " Using POSIX signal() to install vdb fault handler." + fi +fi +if test "$have_vdb_win32" = yes ; then + echo " Using special WIN32 vdb fault handler." +fi +if test "$have_vdb_mach" = yes ; then + echo " Using mach exception mechanism as vdb fault handler." +fi +if test "$have_vdb_fake" = yes && test "$enable_vdb" != fake; then + echo " WARNING: ---------------------------------------------------------" + echo " WARNING: The new incremental garbage collector is enabled, but" + echo " WARNING: a virtual dirty bit implementation is not yet available" + echo " WARNING: on this system. XEmacs will crash if you try to switch on" + echo " WARNUNG: incremental garbage collection!" + echo " WARNING: Use \`--disable-newgc' to turn incremental gc off." + echo " WARNING: ---------------------------------------------------------" +fi +if test "$have_vdb_fake" = yes && test "$enable_vdb" == fake; then + echo " Virtual dirty bit write barrier manually disabled." +fi test "$enable_pdump" = yes && echo " Using the new portable dumper." test "$enable_dump_in_exec" = yes && echo " Dumping into executable." test "$enable_debug" = yes && echo " Compiling in support for extra debugging code." ＠＠ -5981,6 +6093,14 ＠＠ dnl if it exists (i.e. in the src/ direc MAKE_JUNK_C(Makefile.in) CPP_MAKEFILE(,Makefile) CPP_MAKEFILE(-DUSE_GNU_MAKE,GNUmakefile) + if test -r ".gdbinit.in"; then + MAKE_JUNK_C(.gdbinit.in) + CPP_MAKEFILE(,.gdbinit) + fi + if test -r ".dbxrc.in"; then + MAKE_JUNK_C(.dbxrc.in) + CPP_MAKEFILE(,.dbxrc) + fi if test -r "xemacs.def.in"; then dnl #### We should be using MAKE_JUNK_C instead of the next two lines. dnl #### But the comments in xemacs.def.in need to be converted from C-style 1.699 +13 -0 XEmacs/xemacs/lisp/ChangeLog Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/ChangeLog,v retrieving revision 1.698 retrieving revision 1.699 diff -u -p -r1.698 -r1.699 --- ChangeLog 2005/11/16 12:13:02 1.698 +++ ChangeLog 2005/11/25 01:41:45 1.699 ＠＠ -1,3 +1,16 ＠＠ +2005-11-21 Marcus Crestani <crestani(a)xemacs.org&gt; + + Incremental Garbage Collector + + * cus-start.el (all): Add allow-incremental-gc, + gc-cons-incremental-threshold, and + gc-incremental-traversal-threshold to alloc customization group. + * diagnose.el (show-memory-usage): Additionally allocated memory + no longer in use, remove. + * diagnose.el (show-lrecord-stats): Additionally allocated memory + no longer in use, remove. + * diagnose.el (show-gc-stats): New. + 2005-11-08 Malcolm Purvis <malcolmp(a)xemacs.org&gt; * help.el: 1.10 +3 -0 XEmacs/xemacs/lisp/cus-start.el Index: cus-start.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/cus-start.el,v retrieving revision 1.9 retrieving revision 1.10 diff -u -p -r1.9 -r1.10 --- cus-start.el 2002/12/12 03:20:36 1.9 +++ cus-start.el 2005/11/25 01:41:46 1.10 ＠＠ -46,6 +46,7 ＠＠ (let ((all '(;; boolean (abbrev-all-caps abbrev boolean) (allow-deletion-of-last-visible-frame frames boolean) + (allow-incremental-gc alloc boolean) (debug-on-quit debug boolean) (delete-auto-save-files auto-save boolean) (delete-exited-processes processes-basics boolean) ＠＠ -71,6 +72,8 ＠＠ (bell-inhibit-time sound integer) (echo-keystrokes keyboard integer) (gc-cons-threshold alloc integer) + (gc-cons-incremental-threshold alloc integer) + (gc-incremental-traversal-threshold alloc integer) (next-screen-context-lines display integer) (scroll-conservatively display integer) (scroll-step windows integer) 1.7 +51 -12 XEmacs/xemacs/lisp/diagnose.el Index: diagnose.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/diagnose.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -p -r1.6 -r1.7 --- diagnose.el 2005/11/13 10:56:09 1.6 +++ diagnose.el 2005/11/25 01:41:46 1.7 ＠＠ -142,7 +142,7 ＠＠ (princ "\n") (map-plist #'(lambda (stat num) (when (string-match - "\\(.*\\)-storage\\(-additional\\)?$" + "\\(.*\\)-storage\\$" (symbol-name stat)) (incf total num) (princ (format fmt ＠＠ -237,10 +237,6 ＠＠ (setq begin (point)) (princ "Allocated with lisp allocator:\n") (show-stats "\\(.*\\)-storage$") - (princ "\n\n") - (setq begin (point)) - (princ "Allocated additionally:\n") - (show-stats "\\(.*\\)-storage-additional$") (princ (format "\n\ngrand total: %s\n" grandtotal))) grandtotal)))) ＠＠ -253,10 +249,9 ＠＠ (page-size (first stats)) (heap-sects (second stats)) (used-plhs (third stats)) - (unmanaged-plhs (fourth stats)) - (free-plhs (fifth stats)) - (globals (sixth stats)) - (mc-malloced-bytes (seventh stats))) + (free-plhs (fourth stats)) + (globals (fifth stats)) + (mc-malloced-bytes (sixth stats))) (with-output-to-temp-buffer "*memory usage*" (flet ((print-used-plhs (text plhs) (let ((sum-n-pages 0) ＠＠ -372,9 +367,6 ＠＠ (print-used-plhs "USED HEAP" used-plhs) (princ "\n\n") - (print-used-plhs "UNMANAGED HEAP" unmanaged-plhs) - (princ "\n\n") - (print-free-plhs "FREE HEAP" free-plhs) (princ "\n\n") ＠＠ -399,3 +391,50 ＠＠ (princ (format fmt "grand total" mc-malloced-bytes))) (+ mc-malloced-bytes))))) + + +(defun show-gc-stats () + "Show statistics about garbage collection cycles." + (interactive) + (let ((buffer "*garbage collection statistics*") + (plist (gc-stats)) + (fmt "%-9s %10s %10s %10s %10s %10s\n")) + (flet ((plist-get-stat (category field) + (or (plist-get plist (intern (concat category field))) + "-")) + (show-stats (category) + (princ (format fmt category + (plist-get-stat category "-total") + (plist-get-stat category "-in-last-gc") + (plist-get-stat category "-in-this-gc") + (plist-get-stat category "-in-last-cycle") + (plist-get-stat category "-in-this-cycle"))))) + (with-output-to-temp-buffer buffer + (save-excursion + (set-buffer buffer) + (princ (format "%s %s\n" "Current phase" (plist-get plist 'phase))) + (princ (make-string 64 ?-)) + (princ "\n") + (princ (format fmt "stat" "total" "last-gc" "this-gc" + "last-cycle" "this-cylce")) + (princ (make-string 64 ?-)) + (princ "\n") + (show-stats "n-gc") + (show-stats "n-cycles") + (show-stats "enqueued") + (show-stats "dequeued") + (show-stats "repushed") + (show-stats "enqueued2") + (show-stats "dequeued2") + (show-stats "finalized") + (show-stats "freed") + (princ (make-string 64 ?-)) + (princ "\n") + (princ (format fmt "explicitly" + "freed:" + (plist-get-stat "explicitly" "-freed") + "tried:" + (plist-get-stat "explicitly" "-tried-freed") + ""))) + + (plist-get plist 'n-gc-total))))) 1.194 +9 -0 XEmacs/xemacs/nt/ChangeLog Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/nt/ChangeLog,v retrieving revision 1.193 retrieving revision 1.194 diff -u -p -r1.193 -r1.194 --- ChangeLog 2005/11/10 15:45:13 1.193 +++ ChangeLog 2005/11/25 01:41:49 1.194 ＠＠ -1,3 +1,12 ＠＠ +2005-11-21 Marcus Crestani <crestani(a)xemacs.org&gt; + + Incremental Garbage Collector + + * config.inc.samp: Add NEW_GC option. + * xemacs.dsp: Add files gc.c, gc.h, vdb.c, vdb.h, and vdb-win32.c. + * xemacs.mak: Add NEW_GC option; if NEW_GC, turn on KKCC and + MC_ALLOC. + 2005-11-08 Marcus Crestani <crestani(a)xemacs.org&gt; * xemacs.mak: 1.23 +3 -0 XEmacs/xemacs/nt/config.inc.samp Index: config.inc.samp =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/nt/config.inc.samp,v retrieving revision 1.22 retrieving revision 1.23 diff -u -p -r1.22 -r1.23 --- config.inc.samp 2005/09/26 08:13:00 1.22 +++ config.inc.samp 2005/11/25 01:41:50 1.23 ＠＠ -223,6 +223,9 ＠＠ USE_KKCC=1 # Set this to use the new experimental allocator routines MC_ALLOC=1 +# Set this to use the new experimental incremental garbage collector routines +NEW_GC=0 + # Set this to turn on the use of the union type, which gets you improved # type checking of Lisp_Objects -- they're declared as unions instead of # ints, and so places where a Lisp_Object is mistakenly passed to a routine 1.8 +20 -0 XEmacs/xemacs/nt/xemacs.dsp Index: xemacs.dsp =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/nt/xemacs.dsp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xemacs.dsp 2005/04/08 23:11:07 1.7 +++ xemacs.dsp 2005/11/25 01:41:50 1.8 ＠＠ -555,6 +555,14 ＠＠ SOURCE="..\src\free-hook.c" # End Source File # Begin Source File +SOURCE=..\src\gc.c +# End Source File +# Begin Source File + +SOURCE=..\src\gc.h +# End Source File +# Begin Source File + SOURCE=..\src\general.c # End Source File # Begin Source File ＠＠ -1336,6 +1344,18 ＠＠ SOURCE=..\src\unexsunos4.c # Begin Source File SOURCE=..\src\universe.h +# End Source File +# Begin Source File + +SOURCE=..\src\vdb.h +# End Source File +# Begin Source File + +SOURCE=..\src\vdb.c +# End Source File +# Begin Source File + +SOURCE=..\src\vdb-win32.c # End Source File # Begin Source File 1.119 +15 -0 XEmacs/xemacs/nt/xemacs.mak Index: xemacs.mak =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/nt/xemacs.mak,v retrieving revision 1.118 retrieving revision 1.119 diff -u -p -r1.118 -r1.119 --- xemacs.mak 2005/11/10 15:45:13 1.118 +++ xemacs.mak 2005/11/25 01:41:50 1.119 ＠＠ -218,6 +218,9 ＠＠ USE_KKCC=0 !if !defined(MC_ALLOC) MC_ALLOC=0 !endif +!if !defined(NEW_GC) +NEW_GC=0 +!endif !if !defined(USE_UNION_TYPE) USE_UNION_TYPE=0 !endif ＠＠ -639,9 +642,17 ＠＠ OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\dumper.ob OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\unexnt.obj !endif +!if $(NEW_GC) +OPT_DEFINES=$(OPT_DEFINES) -DNEW_GC +OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\vdb.obj $(OUTDIR)\vdb-win32.obj +USE_KKCC=1 +MC_ALLOC=1 +!endif + !if $(USE_KKCC) OPT_DEFINES=$(OPT_DEFINES) -DUSE_KKCC !endif + !if $(MC_ALLOC) OPT_DEFINES=$(OPT_DEFINES) -DMC_ALLOC OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\mc-alloc.obj ＠＠ -848,6 +859,7 ＠＠ TEMACS_COMMON_OBJS= \ $(OUTDIR)\fns.obj \ $(OUTDIR)\font-lock.obj \ $(OUTDIR)\frame.obj \ + $(OUTDIR)\gc.obj \ $(OUTDIR)\general.obj \ $(OUTDIR)\getloadavg.obj \ $(OUTDIR)\glyphs.obj \ ＠＠ -1258,6 +1270,9 ＠＠ XEmacs $(XEMACS_VERSION_STRING) $(xemacs !endif !if $(MC_ALLOC) Using new experimental allocator. +!endif +!if $(NEW_GC) + Using new experimental incremental garbage collector. !endif <<NOKEEP ＠echo -------------------------------------------------------------------- 1.11 +2 -0 XEmacs/xemacs/src/.cvsignore Index: .cvsignore =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/.cvsignore,v retrieving revision 1.10 retrieving revision 1.11 diff -u -p -r1.10 -r1.11 --- .cvsignore 2005/06/28 12:02:42 1.10 +++ .cvsignore 2005/11/25 01:41:52 1.11 ＠＠ -30,3 +30,5 ＠＠ REBUILD_AUTOLOADS dump-size xemacs.def xemacs.def.in +.dbxrc +.gdbinit 1.892 +325 -0 XEmacs/xemacs/src/ChangeLog Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/ChangeLog,v retrieving revision 1.891 retrieving revision 1.892 diff -u -p -r1.891 -r1.892 --- ChangeLog 2005/11/22 11:24:40 1.891 +++ ChangeLog 2005/11/25 01:41:53 1.892 ＠＠ -1,3 +1,328 ＠＠ +2005-11-21 Marcus Crestani <crestani(a)xemacs.org&gt; + + Incremental Garbage Collector + + * .cvsignore: Add .dbxrc and .gdbinit. + + * .dbxrc: Remove. + * .dbxrc.in: New, used to generate .dbxrc: If newgc is enabled, do + not break on SIGBUS and SIGSEGV. + * .gdbinit: Remove. + * .gdbinit: New, used to generate .gdbinit: If newgc is enabled, + do not break on SIGBUS and SIGSEGV. + + * Makefile.in.in: Add gc.c, newgc_objs and vdb_objs. + + * alloc.c: Move the GC related code to gc.c: marking, gc hooks, + garbage_collect_1, GC related Lisp functions and variables. Left + in alloc.c are the allocation functions, the definition of + lrecords, the sweep functions of the old garbage collector, and + root-set code like staticpro and mcpro. Remove + lrecord_string_data_stats. + * alloc.c (DECREMENT_CONS_COUNTER): Remove call to + recompute_need_to_garbage_collect. + * alloc.c (init_lrecord_stats): Remove additionally allocated + memory statistics, i.e. statistics for string data. + * alloc.c (alloc_lrecord_array): New. + * alloc.c (free_lrecord): Do not explicitly free during gc. Add + recompute_need_to_garbage_collect. + * alloc.c (make_compiled_function): Field arguments is now a Lisp + object, thus init it to Qnil rather than NULL. + * alloc.c (struct string_chars_block): + * alloc.c (finalize_string): + * alloc.c (struct string_chars): + * alloc.c (make_uninit_string): + * alloc.c (resize_string): + * alloc.c (make_string_nocopy): + String data is now a Lisp object. Remove code that handled string + data specially. + * alloc.c (init_lrecord_stats): Remove lrecord_string_data_stats. + * alloc.c (common_init_alloc_early): + * alloc.c (init_alloc_once_early): + * alloc.c (syms_of_alloc): + * alloc.c (vars_of_alloc): + * alloc.c (complex_vars_of_alloc): + Move init code to gc.c's inizializers. + + * buffer.c: + * buffer.c (syms_of_buffer): + * buffer.h: + * buffer.h (struct buffer_text): Add new Lisp object: buffer_text. + + * bytecode.c: + * bytecode.c (make_compiled_function_args): + * bytecode.c (optimize_compiled_function): + * bytecode.c (mark_compiled_function): + * bytecode.c (finalize_compiled_function): + * bytecode.c (syms_of_bytecode): + * bytecode.h: + * bytecode.h (struct compiled_function_args): + * bytecode.h (struct Lisp_Compiled_Function): Add new Lisp object: + compiled_function_args. + + * config.h.in: Add NEW_GC symbol, add VDB_* symbols, and symbols + for functions and structs checked for vdb. + + * console-gtk-impl.h: + * console-gtk-impl.h (struct gtk_device): + * console-gtk-impl.h (struct gtk_frame): + * console-msw-impl.h: + * console-msw-impl.h (struct mswindows_device): + * console-msw-impl.h (struct msprinter_device): + * console-msw-impl.h (struct mswindows_frame): + * console-stream-impl.h: + * console-stream-impl.h (struct stream_console): + * console-stream.c: + * console-stream.c (stream_init_console): + * console-stream.c (stream_delete_console): + * console-stream.h: + * console-tty-impl.h: + * console-tty-impl.h (struct tty_console): + * console-tty-impl.h (struct tty_device): + * console-tty.c: + * console-tty.c (allocate_tty_console_struct): + * console-tty.c (free_tty_console_struct): + * console-x-impl.h: + * console-x-impl.h (struct x_device): + * console-x-impl.h (struct x_frame): + * console.c: + * console.c (syms_of_console): Add new Lisp objects: tty_console, + stream_consle. + + * device-gtk.c: + * device-gtk.c (allocate_gtk_device_struct): + * device-gtk.c (free_gtk_device_struct): + * device-gtk.c (syms_of_device_gtk): + * device-msw.c: + * device-msw.c (mswindows_init_device): + * device-msw.c (mswindows_delete_device): + * device-msw.c (msprinter_init_device): + * device-msw.c (msprinter_delete_device): + * device-msw.c (syms_of_device_mswindows): + * device-tty.c: + * device-tty.c (free_tty_device_struct): + * device-tty.c (syms_of_device_tty): + * device-x.c: + * device-x.c (allocate_x_device_struct): + * device-x.c (free_x_device_struct): + * device-x.c (syms_of_device_x): + * device.c: Add new Lisp objects: x_device, gtk_device, + tty_device, mswindows_device, msprinter_device. + + * dumper.c: + * dumper.c (pdump_register_sub): Add XD_LISP_OBJECT_PTR. + * dumper.c (pdump_register_object_array): New. + * dumper.c (pdump_store_new_pointer_offsets): Add XD_LISP_OBJECT_PTR. + * dumper.c (pdump_scan_lisp_objects_by_alignment): Remove assert, + XD_LISP_OBJECT_PTR may occur as arrays. + * dumper.c (pdump_reloc_one_mc): Add XD_LISP_OBJECT_PTR. + * dumper.c (pdump_dump_rtables): Dump arrays. + * dumper.c (pdump_load_finish): Store and restore state of + allow_incremental_gc. Remove lrecord_string_data_stats. + + * dynarr.c: + * dynarr.c (Dynarr_lisp_newf): Special case dynamic Lisp array. + * dynarr.c (Dynarr_resize): Special case dynamic Lisp array. + * dynarr.c (Dynarr_free): Add dynamic Lisp array. + + * elhash.c: + * elhash.c (htentry): + * elhash.c (make_general_lisp_hash_table): + * elhash.c (Fcopy_hash_table): + * elhash.c (resize_hash_table): + * elhash.c (pdump_reorganize_hash_table): + * elhash.c (init_elhash_once_early): + * elhash.h: Add new Lisp object: hash_table_entry. Make + hash_table_entries Lisp objects. + + * emacs.c (main_1): Install platform's vdb signal handler, add GC + init, add syms of GC and vdb, . + * emacs.c: Replace garbage_collect_1 calls with gc_full calls. + * emacs.c (fatal_error_signal): With vdb enabled, convert SIGSEGV + and SIGBUS to SIGABRT. + + * eval.c (Fsignal): Incremental GC may always run, changes are + caught by the write barrier. + * eval.c (handle_compiled_function_with_and_rest): + * eval.c (funcall_compiled_function): + * eval.c (Feval): Invoke incremental GC if need to GC. + * eval.c (Ffuncall): Invoke incremental GC if need to GC. + * eval.c (run_hook_with_args_in_buffer): Add new Lisp object: + compiled_function_args. + + * event-msw.c (mswindows_wnd_proc): Incremental GC may always run, + changes are caught by the write barrier. + * events.c (reinit_vars_of_events): Vevent_resource now + collectible, staticpro it. + + * extents.c: + * extents.c (gap_array_marker): + * extents.c (gap_array): + * extents.c (extent_list_marker): + * extents.c (extent_list): + * extents.c (stack_of_extents): + * extents.c (gap_array_make_gap): + * extents.c (gap_array_make_marker): + * extents.c (gap_array_delete_marker): + * extents.c (gap_array_delete_all_markers): + * extents.c (make_gap_array): + * extents.c (free_gap_array): + * extents.c (extent_list_insert): + * extents.c (extent_list_make_marker): + * extents.c (extent_list_delete_marker): + * extents.c (allocate_extent_list): + * extents.c (free_extent_list): + * extents.c (finalize_extent_info): + * extents.c (flush_cached_extent_info): + * extents.c (uninit_buffer_extents): + * extents.c (allocate_soe): + * extents.c (free_soe): + * extents.c (syms_of_extents): + * extents.h: Add new Lisp object: gap_array_marker, gap_array, + extent_list_marker, extent_list, and stack_of_extents. + + * faces.h: + * faces.h (struct face_cachel): Add new Lisp object: face cachel. + + * frame-gtk.c: + * frame-gtk.c (allocate_gtk_frame_struct): + * frame-gtk.c (gtk_delete_frame): + * frame-gtk.c (syms_of_frame_gtk): + * frame-msw.c: + * frame-msw.c (mswindows_init_frame_1): + * frame-msw.c (mswindows_delete_frame): + * frame-msw.c (syms_of_frame_mswindows): + * frame-x.c: + * frame-x.c (allocate_x_frame_struct): + * frame-x.c (x_delete_frame): + * frame-x.c (syms_of_frame_x): + * frame.c: + * frame.c (change_frame_size): + * frame.c (syms_of_frame): Add new Lisp object: gtk_console, + mswindows_console, and x_console. + + * glyphs.c (struct expose_ignore_blocktype): + * glyphs.c (check_for_ignored_expose): + * glyphs.c (register_ignored_expose): + * glyphs.c (reinit_vars_of_glyphs): + * glyphs.h: + * glyphs.h (struct glyph_cachel): + * glyphs.h (struct expose_ignore): Add new Lisp object: + glyph_cachel and expose_ignore. + + * lisp.h: Move dynamic array definition down after lrecord + inclusion. Add dynamic lisp array macros. Add direct and + indirect string data. Add string accessors. Remove + lrecord_string_data_stats. + * lisp.h (struct Lisp_String_Direct_Data): New. + * lisp.h (struct Lisp_String_Indirect_Data): New. + * lisp.h (struct Lisp_String): Add indirect flag and Lisp object + data. + + * lrecord.h: Remove lrecord_type numbering. + * lrecord.h (enum lrecord_type): Add new Lisp objects. + * lrecord.h (MC_ALLOC_CALL_FINALIZER): Add GC statistics. + * lrecord.h (enum memory_description_type): Add + XD_LISP_OBJECT_BLOCK_PTR. + * lrecord.h (XD_LISP_DYNARR_DESC): New. + * lrecord.h (alloc_lrecord_array): New. + + * mc-alloc.c: + * mc-alloc.c (MIN_HEAP_INCREASE): + * mc-alloc.c (free_link): + * mc-alloc.c (page_header): + * mc-alloc.c (FREE_HEAP_PAGES): + * mc-alloc.c (PH_BLACK_BIT): + * mc-alloc.c (get_mark_bit_index): + * mc-alloc.c (add_pages_to_lookup_table): + * mc-alloc.c (alloc_bit_array): + * mc-alloc.c (get_bit): + * mc-alloc.c (set_bit): + * mc-alloc.c (USE_PNTR_MARK_BITS): + * mc-alloc.c (GET_BIT_WORD): + * mc-alloc.c (SET_BIT_WORD): + * mc-alloc.c (ZERO_MARK_BITS_PNTR): + * mc-alloc.c (alloc_mark_bits): + * mc-alloc.c (free_mark_bits): + * mc-alloc.c (set_mark_bit): + * mc-alloc.c (alloc_page_header): + * mc-alloc.c (free_page_header): + * mc-alloc.c (get_used_list_index): + * mc-alloc.c (get_free_list_index): + * mc-alloc.c (install_cell_free_list): + * mc-alloc.c (install_page_in_used_list): + * mc-alloc.c (remove_page_from_used_list): + * mc-alloc.c (allocate_new_page): + * mc-alloc.c (mc_alloc_1): + * mc-alloc.c (mc_alloc_array): + * mc-alloc.c (mc_alloc): + * mc-alloc.c (mark_free_list): + * mc-alloc.c (finalize_page): + * mc-alloc.c (finalize_page_for_disksave): + * mc-alloc.c (sweep_page): + * mc-alloc.c (mc_free): + * mc-alloc.c (mc_realloc_1): + * mc-alloc.c (mc_realloc_array): + * mc-alloc.c (init_mc_allocator): + * mc-alloc.c (Fmc_alloc_memory_usage): + * mc-alloc.c (maybe_mark_black): + * mc-alloc.h: Add incremental garbage collector support, various + cleanups. + + * objects-tty-impl.h: + * objects-tty-impl.h (struct tty_color_instance_data): + * objects-tty-impl.h (struct tty_font_instance_data): + * objects-tty.c: + * objects-tty.c (tty_initialize_color_instance): + * objects-tty.c (tty_finalize_color_instance): + * objects-tty.c (tty_initialize_font_instance): + * objects-tty.c (tty_finalize_font_instance): + * objects-tty.c (syms_of_objects_tty): + * objects.c: New Lisp objects: color_instance_data and + font_instance_data. + + * print.c (print_internal): New Lisp object: string_data. + + * specifier.c: + * specifier.c (finalize_specifier): + * specifier.c (set_specifier_caching): + * specifier.c (syms_of_specifier): + * specifier.h: + * specifier.h (struct specifier_caching): New Lisp object: + specifier caching. + + * syntax.c: + * syntax.c (init_buffer_syntax_cache): + * syntax.c (uninit_buffer_syntax_cache): + * syntax.c (syms_of_syntax): + * syntax.h: + * syntax.h (struct syntax_cache): New Lisp object: syntax_cache. + + * window.c: + * window.c (allocate_window): + * window.c (make_dummy_parent): + * window.c (syms_of_window): New Lisp objects: face_cachel, + fache_cachel_dynarr, glyph_cachel, and glyph_cachel_dynarr. + + + New files: + * gc.c: Moved code from alloc.c. Split up garbage_collect_1 in a + couple of smaller functions. + * gc.h: Incremental Garbage Collector + + * vdb-fake.c: Virtual dirty bit fake implementation. + * vdb-mach.c: Virtual dirty bit implementation for Mach systems. + * vdb-posix.c: Virtual dirty bit implementation for POSIX systems. + * vdb-win32.c: Virtual dirty bit implementation for Win32 systems. + + * vdb.c: + * vdb.h: Platform independent virtual dirty bit implementation. + + + Remove files: + * .dbxrc: + * .gdbinit: Now generated by configure script. + 2005-11-22 Malcolm Purvis <malcolmp(a)xemacs.org&gt; * frame-gtk.c (gtk_internal_frame_property_p): 1.122 +15 -2 XEmacs/xemacs/src/Makefile.in.in Index: Makefile.in.in =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/Makefile.in.in,v retrieving revision 1.121 retrieving revision 1.122 diff -u -p -r1.121 -r1.122 --- Makefile.in.in 2005/11/22 07:14:44 1.121 +++ Makefile.in.in 2005/11/25 01:41:55 1.122 ＠＠ -255,6 +255,19 ＠＠ win32_objs=win32.o intl-win32.o intl-aut mc_alloc_objs=mc-alloc.o #endif +#ifdef NEW_GC +new_gc_objs=vdb.o +# if defined (WIN32_ANY) || defined (VDB_WIN32) +vdb_objs=vdb-win32.o +# elif defined (VDB_MACH) +vdb_objs=vdb-mach.o +# elif defined (VDB_POSIX) +vdb_objs=vdb-posix.o +# else /* VDB_FAKE */ +vdb_objs=vdb-fake.o +# endif +#endif /* NEW_GC */ + ## lastfile must follow all files whose initialized data areas should ## be dumped as pure by dump-emacs. ＠＠ -273,12 +286,12 ＠＠ objs=\ event-stream.o $(event_unixoid_objs) $(extra_objs) extents.o\ faces.o file-coding.o fileio.o $(LOCK_OBJ) filemode.o floatfns.o fns.o \ font-lock.o frame.o\ - general.o $(gif_objs) glyphs.o glyphs-eimage.o glyphs-shared.o\ + gc.o general.o $(gif_objs) glyphs.o glyphs-eimage.o glyphs-shared.o\ glyphs-widget.o $(gpm_objs) $(gtk_objs) $(gtk_gui_objs) $(gui_objs) \ gutter.o\ hash.o imgproc.o indent.o insdel.o intl.o\ keymap.o $(RTC_patch_objs) line-number.o $(ldap_objs) lread.o lstream.o\ - $(mc_alloc_objs) \ + $(mc_alloc_objs) $(new_gc_objs) $(vdb_objs) \ macros.o marker.o md5.o minibuf.o $(mswindows_objs) $(mswindows_gui_objs)\ $(mule_objs) $(mule_canna_objs) $(mule_wnn_objs) $(number_objs) objects.o\ opaque.o $(postgresql_objs) print.o process.o $(process_objs) $(profile_objs)\ 1.120 +286 -1507 XEmacs/xemacs/src/alloc.c Index: alloc.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/alloc.c,v retrieving revision 1.119 retrieving revision 1.120 diff -u -p -r1.119 -r1.120 --- alloc.c 2005/11/13 10:48:02 1.119 +++ alloc.c 2005/11/25 01:41:55 1.120 ＠＠ -52,6 +52,7 ＠＠ Boston, MA 02111-1307, USA. */ #include "extents-impl.h" #include "file-coding.h" #include "frame-impl.h" +#include "gc.h" #include "glyphs.h" #include "opaque.h" #include "lstream.h" ＠＠ -62,6 +63,9 ＠＠ Boston, MA 02111-1307, USA. */ #include "sysfile.h" #include "sysdep.h" #include "window.h" +#ifdef NEW_GC +#include "vdb.h" +#endif /* NEW_GC */ #include "console-stream.h" #ifdef DOUG_LEA_MALLOC ＠＠ -70,8 +74,6 ＠＠ Boston, MA 02111-1307, USA. */ EXFUN (Fgarbage_collect, 0); -static void recompute_need_to_garbage_collect (void); - #if 0 /* this is _way_ too slow to be part of the standard debug options */ #if defined(DEBUG_XEMACS) && defined(MULE) #define VERIFY_STRING_CHARS_INTEGRITY ＠＠ -91,13 +93,6 ＠＠ static Fixnum debug_allocation; static Fixnum debug_allocation_backtrace_length; #endif -/* Number of bytes of consing done since the last gc */ -static EMACS_INT consing_since_gc; -EMACS_UINT total_consing; -EMACS_INT total_gc_usage; -int total_gc_usage_set; - -int need_to_garbage_collect; int need_to_check_c_alloca; int need_to_signal_post_gc; int funcall_allocation_flag; ＠＠ -149,6 +144,20 ＠＠ do { \ INCREMENT_CONS_COUNTER_1 (size) #endif +#ifdef NEW_GC +/* The call to recompute_need_to_garbage_collect is moved to + free_lrecord, since DECREMENT_CONS_COUNTER is extensively called + during sweep and recomputing need_to_garbage_collect all the time + is not needed. */ +#define DECREMENT_CONS_COUNTER(size) do { \ + consing_since_gc -= (size); \ + total_consing -= (size); \ + if (profiling_active) \ + profile_record_unconsing (size); \ + if (consing_since_gc < 0) \ + consing_since_gc = 0; \ +} while (0) +#else /* not NEW_GC */ #define DECREMENT_CONS_COUNTER(size) do { \ consing_since_gc -= (size); \ total_consing -= (size); \ ＠＠ -158,51 +167,11 ＠＠ do { \ consing_since_gc = 0; \ recompute_need_to_garbage_collect (); \ } while (0) +#endif /*not NEW_GC */ -/* Number of bytes of consing since gc before another gc should be done. */ -static EMACS_INT gc_cons_threshold; - -/* Percentage of consing of total data size before another GC. */ -static EMACS_INT gc_cons_percentage; - -#ifdef ERROR_CHECK_GC -int always_gc; /* Debugging hack; equivalent to - (setq gc-cons-thresold -1) */ -#else -#define always_gc 0 -#endif - -/* Nonzero during gc */ -int gc_in_progress; - -/* Nonzero means display messages at beginning and end of GC. */ - -int garbage_collection_messages; - -/* Number of times GC has happened at this level or below. - * Level 0 is most volatile, contrary to usual convention. - * (Of course, there's only one level at present) */ -EMACS_INT gc_generation_number[1]; - /* This is just for use by the printer, to allow things to print uniquely */ int lrecord_uid_counter; -/* Nonzero when calling certain hooks or doing other things where - a GC would be bad */ -int gc_currently_forbidden; - -/* Hooks. */ -Lisp_Object Vpre_gc_hook, Qpre_gc_hook; -Lisp_Object Vpost_gc_hook, Qpost_gc_hook; - -/* "Garbage collecting" */ -Lisp_Object Vgc_message; -Lisp_Object Vgc_pointer_glyph; -static const Ascbyte gc_default_message[] = "Garbage collecting"; -Lisp_Object Qgarbage_collecting; - -static Lisp_Object QSin_garbage_collection; - /* Non-zero means we're in the process of doing the dump */ int purify_flag; ＠＠ -248,7 +217,7 ＠＠ int ignore_malloc_warnings;  #ifndef MC_ALLOC -static void *breathing_space; +void *breathing_space; void release_breathing_space (void) ＠＠ -282,6 +251,7 ＠＠ malloc_warning (const char *str) DOESNT_RETURN memory_full (void) { + fprintf (stderr, "##### M E M O R Y F U L L #####\n"); /* Force a GC next time eval is called. It's better to loop garbage-collecting (we might reclaim enough to win) than to loop beeping and barfing "Memory exhausted" ＠＠ -521,33 +491,10 ＠＠ static struct } lrecord_stats [countof (lrecord_implementations_table) + MODULE_DEFINABLE_TYPE_COUNT]; -int lrecord_string_data_instances_in_use; -int lrecord_string_data_bytes_in_use; -int lrecord_string_data_bytes_in_use_including_overhead; - void init_lrecord_stats () { xzero (lrecord_stats); - lrecord_string_data_instances_in_use = 0; - lrecord_string_data_bytes_in_use = 0; - lrecord_string_data_bytes_in_use_including_overhead = 0; -} - -void -inc_lrecord_string_data_stats (Bytecount size) -{ - lrecord_string_data_instances_in_use++; - lrecord_string_data_bytes_in_use += size; - lrecord_string_data_bytes_in_use_including_overhead += size; -} - -void -dec_lrecord_string_data_stats (Bytecount size) -{ - lrecord_string_data_instances_in_use--; - lrecord_string_data_bytes_in_use -= size; - lrecord_string_data_bytes_in_use_including_overhead -= size; } void ＠＠ -581,6 +528,17 ＠＠ dec_lrecord_stats (Bytecount size_includ DECREMENT_CONS_COUNTER (size); } + +int +lrecord_stats_heap_size (void) +{ + int i; + int size = 0; + for (i = 0; i < (countof (lrecord_implementations_table) + + MODULE_DEFINABLE_TYPE_COUNT); i++) + size += lrecord_stats[i].bytes_in_use; + return size; +} #endif /* not (MC_ALLOC && ALLOC_TYPE_STATS) */ #ifndef MC_ALLOC ＠＠ -613,6 +571,7 ＠＠ alloc_lrecord (Bytecount size, return lheader; } + void * noseeum_alloc_lrecord (Bytecount size, const struct lrecord_implementation *implementation) ＠＠ -634,15 +593,59 ＠＠ noseeum_alloc_lrecord (Bytecount size, return lheader; } +#ifdef NEW_GC +void * +alloc_lrecord_array (Bytecount size, int elemcount, + const struct lrecord_implementation *implementation) +{ + struct lrecord_header *lheader; + Rawbyte *start, *stop; + + type_checking_assert + ((implementation->static_size == 0 ? + implementation->size_in_bytes_method != NULL : + implementation->static_size == size)); + + lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount); + gc_checking_assert (LRECORD_FREE_P (lheader)); + + for (start = (Rawbyte *) lheader, + stop = ((Rawbyte *) lheader) + (size * elemcount -1); + start < stop; start += size) + { + struct lrecord_header *lh = (struct lrecord_header *) start; + set_lheader_implementation (lh, implementation); + lh->uid = lrecord_uid_counter++; +#ifdef ALLOC_TYPE_STATS + inc_lrecord_stats (size, lh); +#endif /* not ALLOC_TYPE_STATS */ + } + INCREMENT_CONS_COUNTER (size * elemcount, implementation->name); + return lheader; +} +#endif /* NEW_GC */ + void free_lrecord (Lisp_Object lrecord) { +#ifndef NEW_GC gc_checking_assert (!gc_in_progress); +#endif /* not NEW_GC */ gc_checking_assert (!LRECORD_FREE_P (XRECORD_LHEADER (lrecord))); gc_checking_assert (!XRECORD_LHEADER (lrecord)->free); +#ifdef NEW_GC + GC_STAT_EXPLICITLY_TRIED_FREED; + /* Ignore requests to manual free objects while in garbage collection. */ + if (write_barrier_enabled || gc_in_progress) + return; + + GC_STAT_EXPLICITLY_FREED; +#endif /* NEW_GC */ + MC_ALLOC_CALL_FINALIZER (XPNTR (lrecord)); mc_free (XPNTR (lrecord)); + recompute_need_to_garbage_collect (); } #else /* not MC_ALLOC */ ＠＠ -955,16 +958,6 ＠＠ dbg_eq (Lisp_Object obj1, Lisp_Object ob remain free for the next 1000 (or whatever) times that an object of that type is allocated. */ -#ifndef MALLOC_OVERHEAD -#ifdef GNU_MALLOC -#define MALLOC_OVERHEAD 0 -#elif defined (rcheck) -#define MALLOC_OVERHEAD 20 -#else -#define MALLOC_OVERHEAD 8 -#endif -#endif /* MALLOC_OVERHEAD */ - #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) /* If we released our reserve (due to running out of memory), and we have a fair amount free once again, ＠＠ -1832,7 +1825,11 ＠＠ make_compiled_function (void) f->instructions = Qzero; f->constants = Qzero; f->arglist = Qnil; +#ifdef NEW_GC + f->arguments = Qnil; +#else /* not NEW_GC */ f->args = NULL; +#endif /* not NEW_GC */ f->max_args = f->min_args = f->args_in_array = 0; f->doc_and_interactive = Qnil; #ifdef COMPILED_FUNCTION_ANNOTATION_HACK ＠＠ -2238,8 +2235,12 ＠＠ string_equal (Lisp_Object obj1, Lisp_Obj } static const struct memory_description string_description[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Lisp_String, data_object) }, +#else /* not NEW_GC */ { XD_BYTECOUNT, offsetof (Lisp_String, size_) }, { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) }, +#endif /* not NEW_GC */ { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, { XD_END } }; ＠＠ -2310,6 +2311,10 ＠＠ DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH Lisp_String); #endif /* not MC_ALLOC */ +#ifdef NEW_GC +#define STRING_FULLSIZE(size) \ + ALIGN_SIZE (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_String_Direct_Data, Lisp_Object, data, (size) + 1), sizeof (Lisp_Object *)); +#else /* not NEW_GC */ /* String blocks contain this many useful bytes. */ #define STRING_CHARS_BLOCK_SIZE \ ((Bytecount) (8192 - MALLOC_OVERHEAD - \ ＠＠ -2341,8 +2346,10 ＠＠ static struct string_chars_block *curren #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL) #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL)) +#endif /* not NEW_GC */ #ifdef MC_ALLOC +#ifndef NEW_GC static void finalize_string (void *header, int for_disksave) { ＠＠ -2350,9 +2357,6 ＠＠ finalize_string (void *header, int for_d { Lisp_String *s = (Lisp_String *) header; Bytecount size = s->size_; -#ifdef ALLOC_TYPE_STATS - dec_lrecord_string_data_stats (size); -#endif /* ALLOC_TYPE_STATS */ if (BIG_STRING_SIZE_P (size)) xfree (s->data_, Ibyte *); } ＠＠ -2369,9 +2373,58 ＠＠ DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS string_remprop, string_plist, Lisp_String); +#else /* NEW_GC */ +DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, + 1, /*dumpable-flag*/ + mark_string, print_string, + 0, + string_equal, 0, + string_description, + string_getprop, + string_putprop, + string_remprop, + string_plist, + Lisp_String); + + +static const struct memory_description string_direct_data_description[] = { + { XD_BYTECOUNT, offsetof (Lisp_String_Indirect_Data, size) }, + { XD_END } +}; +static Bytecount +size_string_direct_data (const void *lheader) +{ + return STRING_FULLSIZE (((Lisp_String_Direct_Data *) lheader)->size); +} + + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("string-direct-data", + string_direct_data, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + string_direct_data_description, + size_string_direct_data, + Lisp_String_Direct_Data); + + +static const struct memory_description string_indirect_data_description[] = { + { XD_BYTECOUNT, offsetof (Lisp_String_Indirect_Data, size) }, + { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String_Indirect_Data, data), + XD_INDIRECT(0, 1) }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("string-indirect-data", + string_indirect_data, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + string_indirect_data_description, + Lisp_String_Indirect_Data); +#endif /* NEW_GC */ #endif /* MC_ALLOC */ +#ifndef NEW_GC struct string_chars { Lisp_String *string; ＠＠ -2438,6 +2491,7 ＠＠ allocate_string_chars_struct (Lisp_Objec return s_chars; } +#endif /* not NEW_GC */ #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN void ＠＠ -2472,9 +2526,6 ＠＠ make_uninit_string (Bytecount length) #ifdef MC_ALLOC s = alloc_lrecord_type (Lisp_String, &lrecord_string); -#ifdef ALLOC_TYPE_STATS - inc_lrecord_string_data_stats (length); -#endif /* ALLOC_TYPE_STATS */ #else /* not MC_ALLOC */ /* Allocate the string header */ ALLOCATE_FIXED_TYPE (string, Lisp_String, s); ＠＠ -2486,10 +2537,16 ＠＠ make_uninit_string (Bytecount length) ascii-length field, to some non-zero value. We need to zero it. */ XSET_STRING_ASCII_BEGIN (wrap_string (s), 0); +#ifdef NEW_GC + STRING_DATA_OBJECT (s) = + wrap_string_direct_data (alloc_lrecord (fullsize, + &lrecord_string_direct_data)); +#else /* not NEW_GC */ set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) ? allocate_big_string_chars (length + 1) : allocate_string_chars_struct (wrap_string (s), fullsize)->chars); +#endif /* not NEW_GC */ set_lispstringp_length (s, length); s->plist = Qnil; ＠＠ -2511,7 +2568,11 ＠＠ static void verify_string_chars_integrit void resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) { +#ifdef NEW_GC + Bytecount newfullsize, len; +#else /* not NEW_GC */ Bytecount oldfullsize, newfullsize; +#endif /* not NEW_GC */ #ifdef VERIFY_STRING_CHARS_INTEGRITY verify_string_chars_integrity (); #endif ＠＠ -2539,6 +2600,23 ＠＠ resize_string (Lisp_Object s, Bytecount so convert this to the appropriate form. */ pos += -delta; +#ifdef NEW_GC + newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); + + len = XSTRING_LENGTH (s) + 1 - pos; + + if (delta < 0 && pos >= 0) + memmove (XSTRING_DATA (s) + pos + delta, + XSTRING_DATA (s) + pos, len); + + XSTRING_DATA_OBJECT (s) = + wrap_string_direct_data (mc_realloc (XPNTR (XSTRING_DATA_OBJECT (s)), + newfullsize)); + if (delta > 0 && pos >= 0) + memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, + len); + +#else /* NEW_GC */ oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s)); newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); ＠＠ -2631,6 +2709,7 ＠＠ resize_string (Lisp_Object s, Bytecount } } } +#endif /* not NEW_GC */ XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); /* If pos < 0, the string won't be zero-terminated. ＠＠ -2852,9 +2931,6 ＠＠ make_string_nocopy (const Ibyte *content #ifdef MC_ALLOC s = alloc_lrecord_type (Lisp_String, &lrecord_string); -#ifdef ALLOC_TYPE_STATS - inc_lrecord_string_data_stats (length); -#endif /* ALLOC_TYPE_STATS */ mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get collected and static data is tried to be freed. */ ＠＠ -2867,8 +2943,18 ＠＠ make_string_nocopy (const Ibyte *content /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in init_string_ascii_begin(). */ s->plist = Qnil; +#ifdef NEW_GC + set_lispstringp_indirect (s); + STRING_DATA_OBJECT (s) = + wrap_string_indirect_data + (alloc_lrecord_type (Lisp_String_Indirect_Data, + &lrecord_string_indirect_data)); + XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents; + XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length; +#else /* not NEW_GC */ set_lispstringp_data (s, (Ibyte *) contents); set_lispstringp_length (s, length); +#endif /* not NEW_GC */ val = wrap_string (s); init_string_ascii_begin (val); sledgehammer_check_ascii_begin (val); ＠＠ -3337,899 +3423,118 ＠＠ mcpro (Lisp_Object varaddress) #endif /* not DEBUG_XEMACS */ #endif /* MC_ALLOC */ -#ifdef ERROR_CHECK_GC -#ifdef MC_ALLOC -#define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ - struct lrecord_header * GCLI_lh = (lheader); \ - assert (GCLI_lh != 0); \ - assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ -} while (0) -#else /* not MC_ALLOC */ -#define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ - struct lrecord_header * GCLI_lh = (lheader); \ - assert (GCLI_lh != 0); \ - assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ - assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \ - (MARKED_RECORD_HEADER_P (GCLI_lh) && \ - LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \ -} while (0) -#endif /* not MC_ALLOC */ -#else -#define GC_CHECK_LHEADER_INVARIANTS(lheader) -#endif - - -static const struct memory_description lisp_object_description_1[] = { - { XD_LISP_OBJECT, 0 }, - { XD_END } -}; - -const struct sized_memory_description lisp_object_description = { - sizeof (Lisp_Object), - lisp_object_description_1 -}; -#if defined (USE_KKCC) || defined (PDUMP) +#ifndef MC_ALLOC +static int gc_count_num_short_string_in_use; +static Bytecount gc_count_string_total_size; +static Bytecount gc_count_short_string_total_size; -/* This function extracts the value of a count variable described somewhere - else in the description. It is converted corresponding to the type */ -EMACS_INT -lispdesc_indirect_count_1 (EMACS_INT code, - const struct memory_description *idesc, - const void *idata) -{ - EMACS_INT count; - const void *irdata; - - int line = XD_INDIRECT_VAL (code); - int delta = XD_INDIRECT_DELTA (code); - - irdata = ((char *) idata) + - lispdesc_indirect_count (idesc[line].offset, idesc, idata); - switch (idesc[line].type) - { - case XD_BYTECOUNT: - count = * (Bytecount *) irdata; - break; - case XD_ELEMCOUNT: - count = * (Elemcount *) irdata; - break; - case XD_HASHCODE: - count = * (Hashcode *) irdata; - break; - case XD_INT: - count = * (int *) irdata; - break; - case XD_LONG: - count = * (long *) irdata; - break; - default: - stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", - idesc[line].type, line, (long) code); -#if defined(USE_KKCC) && defined(DEBUG_XEMACS) - if (gc_in_progress) - kkcc_backtrace (); -#endif -#ifdef PDUMP - if (in_pdump) - pdump_backtrace (); -#endif - count = 0; /* warning suppression */ - ABORT (); - } - count += delta; - return count; -} +/* static int gc_count_total_records_used, gc_count_records_total_size; */ -/* SDESC is a "description map" (basically, a list of offsets used for - successive indirections) and OBJ is the first object to indirect off of. - Return the description ultimately found. */ + +/* stats on lcrecords in use - kinda kludgy */ -const struct sized_memory_description * -lispdesc_indirect_description_1 (const void *obj, - const struct sized_memory_description *sdesc) +static struct { - int pos; - - for (pos = 0; sdesc[pos].size >= 0; pos++) - obj = * (const void **) ((const char *) obj + sdesc[pos].size); - - return (const struct sized_memory_description *) obj; -} - -/* Compute the size of the data at RDATA, described by a single entry - DESC1 in a description array. OBJ and DESC are used for - XD_INDIRECT references. */ + int instances_in_use; + int bytes_in_use; + int instances_freed; + int bytes_freed; + int instances_on_free_list; +} lcrecord_stats [countof (lrecord_implementations_table) + + MODULE_DEFINABLE_TYPE_COUNT]; -static Bytecount -lispdesc_one_description_line_size (void *rdata, - const struct memory_description *desc1, - const void *obj, - const struct memory_description *desc) +static void +tick_lcrecord_stats (const struct lrecord_header *h, int free_p) { - union_switcheroo: - switch (desc1->type) - { - case XD_LISP_OBJECT_ARRAY: - { - EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); - return (val * sizeof (Lisp_Object)); - } - case XD_LISP_OBJECT: - case XD_LO_LINK: - return sizeof (Lisp_Object); - case XD_OPAQUE_PTR: - return sizeof (void *); - case XD_BLOCK_PTR: - { - EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); - return val * sizeof (void *); - } - case XD_BLOCK_ARRAY: - { - EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); - - return (val * - lispdesc_block_size - (rdata, - lispdesc_indirect_description (obj, desc1->data2.descr))); - } - case XD_OPAQUE_DATA_PTR: - return sizeof (void *); - case XD_UNION_DYNAMIC_SIZE: - { - /* If an explicit size was given in the first-level structure - description, use it; else compute size based on current union - constant. */ - const struct sized_memory_description *sdesc = - lispdesc_indirect_description (obj, desc1->data2.descr); - if (sdesc->size) - return sdesc->size; - else - { - desc1 = lispdesc_process_xd_union (desc1, desc, obj); - if (desc1) - goto union_switcheroo; - break; - } - } - case XD_UNION: - { - /* If an explicit size was given in the first-level structure - description, use it; else compute size based on maximum of all - possible structures. */ - const struct sized_memory_description *sdesc = - lispdesc_indirect_description (obj, desc1->data2.descr); - if (sdesc->size) - return sdesc->size; - else - { - int count; - Bytecount max_size = -1, size; - - desc1 = sdesc->description; + int type_index = h->type; - for (count = 0; desc1[count].type != XD_END; count++) - { - size = lispdesc_one_description_line_size (rdata, - &desc1[count], - obj, desc); - if (size > max_size) - max_size = size; - } - return max_size; - } - } - case XD_ASCII_STRING: - return sizeof (void *); - case XD_DOC_STRING: - return sizeof (void *); - case XD_INT_RESET: - return sizeof (int); - case XD_BYTECOUNT: - return sizeof (Bytecount); - case XD_ELEMCOUNT: - return sizeof (Elemcount); - case XD_HASHCODE: - return sizeof (Hashcode); - case XD_INT: - return sizeof (int); - case XD_LONG: - return sizeof (long); - default: - stderr_out ("Unsupported dump type : %d\n", desc1->type); - ABORT (); + if (((struct old_lcrecord_header *) h)->free) + { + gc_checking_assert (!free_p); + lcrecord_stats[type_index].instances_on_free_list++; } - - return 0; -} - - -/* Return the size of the memory block (NOT necessarily a structure!) - described by SDESC and pointed to by OBJ. If SDESC records an - explicit size (i.e. non-zero), it is simply returned; otherwise, - the size is calculated by the maximum offset and the size of the - object at that offset, rounded up to the maximum alignment. In - this case, we may need the object, for example when retrieving an - "indirect count" of an inlined array (the count is not constant, - but is specified by one of the elements of the memory block). (It - is generally not a problem if we return an overly large size -- we - will simply end up reserving more space than necessary; but if the - size is too small we could be in serious trouble, in particular - with nested inlined structures, where there may be alignment - padding in the middle of a block. #### In fact there is an (at - least theoretical) problem with an overly large size -- we may - trigger a protection fault when reading from invalid memory. We - need to handle this -- perhaps in a stupid but dependable way, - i.e. by trapping SIGSEGV and SIGBUS.) */ - -Bytecount -lispdesc_block_size_1 (const void *obj, Bytecount size, - const struct memory_description *desc) -{ - EMACS_INT max_offset = -1; - int max_offset_pos = -1; - int pos; - - if (size) - return size; - - for (pos = 0; desc[pos].type != XD_END; pos++) + else { - EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); - if (offset == max_offset) + Bytecount sz = detagged_lisp_object_size (h); + + if (free_p) { - stderr_out ("Two relocatable elements at same offset?\n"); - ABORT (); + lcrecord_stats[type_index].instances_freed++; + lcrecord_stats[type_index].bytes_freed += sz; } - else if (offset > max_offset) + else { - max_offset = offset; - max_offset_pos = pos; + lcrecord_stats[type_index].instances_in_use++; + lcrecord_stats[type_index].bytes_in_use += sz; } } - - if (max_offset_pos < 0) - return 0; - - { - Bytecount size_at_max; - size_at_max = - lispdesc_one_description_line_size ((char *) obj + max_offset, - &desc[max_offset_pos], obj, desc); - - /* We have no way of knowing the required alignment for this structure, - so just make it maximally aligned. */ - return MAX_ALIGN_SIZE (max_offset + size_at_max); - } } +#endif /* not MC_ALLOC */ -#endif /* defined (USE_KKCC) || defined (PDUMP) */ + +#ifndef MC_ALLOC +/* Free all unmarked records */ +static void +sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used) +{ + struct old_lcrecord_header *header; + int num_used = 0; + /* int total_size = 0; */ -#ifdef MC_ALLOC -#define GC_CHECK_NOT_FREE(lheader) \ - gc_checking_assert (! LRECORD_FREE_P (lheader)); -#else /* MC_ALLOC */ -#define GC_CHECK_NOT_FREE(lheader) \ - gc_checking_assert (! LRECORD_FREE_P (lheader)); \ - gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ - ! ((struct old_lcrecord_header *) lheader)->free) -#endif /* MC_ALLOC */ + xzero (lcrecord_stats); /* Reset all statistics to 0. */ -#ifdef USE_KKCC -/* The following functions implement the new mark algorithm. - They mark objects according to their descriptions. They - are modeled on the corresponding pdumper procedures. */ + /* First go through and call all the finalize methods. + Then go through and free the objects. There used to + be only one loop here, with the call to the finalizer + occurring directly before the xfree() below. That + is marginally faster but much less safe -- if the + finalize method for an object needs to reference any + other objects contained within it (and many do), + we could easily be screwed by having already freed that + other object. */ -#ifdef DEBUG_XEMACS -/* The backtrace for the KKCC mark functions. */ -#define KKCC_INIT_BT_STACK_SIZE 4096 + for (header = *prev; header; header = header->next) + { + struct lrecord_header *h = &(header->lheader); -typedef struct -{ - void *obj; - const struct memory_description *desc; - int pos; -} kkcc_bt_stack_entry; - -static kkcc_bt_stack_entry *kkcc_bt; -static int kkcc_bt_stack_size; -static int kkcc_bt_depth = 0; + GC_CHECK_LHEADER_INVARIANTS (h); -static void -kkcc_bt_init (void) -{ - kkcc_bt_depth = 0; - kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE; - kkcc_bt = (kkcc_bt_stack_entry *) - malloc (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); - if (!kkcc_bt) - { - stderr_out ("KKCC backtrace stack init failed for size %d\n", - kkcc_bt_stack_size); - ABORT (); + if (! MARKED_RECORD_HEADER_P (h) && ! header->free) + { + if (LHEADER_IMPLEMENTATION (h)->finalizer) + LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); + } } -} -void -kkcc_backtrace (void) -{ - int i; - stderr_out ("KKCC mark stack backtrace :\n"); - for (i = kkcc_bt_depth - 1; i >= 0; i--) + for (header = *prev; header; ) { - Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj); - stderr_out (" [%d]", i); -#ifdef MC_ALLOC - if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type) -#else /* not MC_ALLOC */ - if ((XRECORD_LHEADER (obj)->type >= lrecord_type_free) -#endif /* not MC_ALLOC */ - || (!LRECORDP (obj)) - || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) + struct lrecord_header *h = &(header->lheader); + if (MARKED_RECORD_HEADER_P (h)) { - stderr_out (" non Lisp Object"); + if (! C_READONLY_RECORD_HEADER_P (h)) + UNMARK_RECORD_HEADER (h); + num_used++; + /* total_size += n->implementation->size_in_bytes (h);*/ + /* #### May modify header->next on a C_READONLY lcrecord */ + prev = &(header->next); + header = *prev; + tick_lcrecord_stats (h, 0); } else { - stderr_out (" %s", - XRECORD_LHEADER_IMPLEMENTATION (obj)->name); + struct old_lcrecord_header *next = header->next; + *prev = next; + tick_lcrecord_stats (h, 1); + /* used to call finalizer right here. */ + xfree (header, struct old_lcrecord_header *); + header = next; } - stderr_out (" (addr: 0x%x, desc: 0x%x, ", - (int) kkcc_bt[i].obj, - (int) kkcc_bt[i].desc); - if (kkcc_bt[i].pos >= 0) - stderr_out ("pos: %d)\n", kkcc_bt[i].pos); - else - stderr_out ("root set)\n"); - } -} - -static void -kkcc_bt_stack_realloc (void) -{ - kkcc_bt_stack_size *= 2; - kkcc_bt = (kkcc_bt_stack_entry *) - realloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); - if (!kkcc_bt) - { - stderr_out ("KKCC backtrace stack realloc failed for size %d\n", - kkcc_bt_stack_size); - ABORT (); } + *used = num_used; + /* *total = total_size; */ } -static void -kkcc_bt_free (void) -{ - free (kkcc_bt); - kkcc_bt = 0; - kkcc_bt_stack_size = 0; -} - -static void -kkcc_bt_push (void *obj, const struct memory_description *desc, - int level, int pos) -{ - kkcc_bt_depth = level; - kkcc_bt[kkcc_bt_depth].obj = obj; - kkcc_bt[kkcc_bt_depth].desc = desc; - kkcc_bt[kkcc_bt_depth].pos = pos; - kkcc_bt_depth++; - if (kkcc_bt_depth >= kkcc_bt_stack_size) - kkcc_bt_stack_realloc (); -} - -#else /* not DEBUG_XEMACS */ -#define kkcc_bt_init() -#define kkcc_bt_push(obj, desc, level, pos) -#endif /* not DEBUG_XEMACS */ - -/* Object memory descriptions are in the lrecord_implementation structure. - But copying them to a parallel array is much more cache-friendly. */ -const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)]; - -/* the initial stack size in kkcc_gc_stack_entries */ -#define KKCC_INIT_GC_STACK_SIZE 16384 - -typedef struct -{ - void *data; - const struct memory_description *desc; -#ifdef DEBUG_XEMACS - int level; - int pos; -#endif -} kkcc_gc_stack_entry; - -static kkcc_gc_stack_entry *kkcc_gc_stack_ptr; -static kkcc_gc_stack_entry *kkcc_gc_stack_top; -static kkcc_gc_stack_entry *kkcc_gc_stack_last_entry; -static int kkcc_gc_stack_size; - -static void -kkcc_gc_stack_init (void) -{ - kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE; - kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) - malloc (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); - if (!kkcc_gc_stack_ptr) - { - stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size); - ABORT (); - } - kkcc_gc_stack_top = kkcc_gc_stack_ptr - 1; - kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; -} - -static void -kkcc_gc_stack_free (void) -{ - free (kkcc_gc_stack_ptr); - kkcc_gc_stack_ptr = 0; - kkcc_gc_stack_top = 0; - kkcc_gc_stack_size = 0; -} - -static void -kkcc_gc_stack_realloc (void) -{ - int current_offset = (int)(kkcc_gc_stack_top - kkcc_gc_stack_ptr); - kkcc_gc_stack_size *= 2; - kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) - realloc (kkcc_gc_stack_ptr, - kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); - if (!kkcc_gc_stack_ptr) - { - stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size); - ABORT (); - } - kkcc_gc_stack_top = kkcc_gc_stack_ptr + current_offset; - kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; -} - -#define KKCC_GC_STACK_FULL (kkcc_gc_stack_top >= kkcc_gc_stack_last_entry) -#define KKCC_GC_STACK_EMPTY (kkcc_gc_stack_top < kkcc_gc_stack_ptr) - -static void -#ifdef DEBUG_XEMACS -kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc, - int level, int pos) -#else -kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc) -#endif -{ - if (KKCC_GC_STACK_FULL) - kkcc_gc_stack_realloc(); - kkcc_gc_stack_top++; - kkcc_gc_stack_top->data = data; - kkcc_gc_stack_top->desc = desc; -#ifdef DEBUG_XEMACS - kkcc_gc_stack_top->level = level; - kkcc_gc_stack_top->pos = pos; -#endif -} - -#ifdef DEBUG_XEMACS -#define kkcc_gc_stack_push(data, desc, level, pos) \ - kkcc_gc_stack_push_1 (data, desc, level, pos) -#else -#define kkcc_gc_stack_push(data, desc, level, pos) \ - kkcc_gc_stack_push_1 (data, desc) -#endif - -static kkcc_gc_stack_entry * -kkcc_gc_stack_pop (void) -{ - if (KKCC_GC_STACK_EMPTY) - return 0; - kkcc_gc_stack_top--; - return kkcc_gc_stack_top + 1; -} - -void -#ifdef DEBUG_XEMACS -kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos) -#else -kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj) -#endif -{ - if (XTYPE (obj) == Lisp_Type_Record) - { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - const struct memory_description *desc; - GC_CHECK_LHEADER_INVARIANTS (lheader); - desc = RECORD_DESCRIPTION (lheader); - if (! MARKED_RECORD_HEADER_P (lheader)) - { - MARK_RECORD_HEADER (lheader); - kkcc_gc_stack_push ((void*) lheader, desc, level, pos); - } - } -} - -#ifdef DEBUG_XEMACS -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) -#else -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj) -#endif - -#ifdef ERROR_CHECK_GC -#define KKCC_DO_CHECK_FREE(obj, allow_free) \ -do \ -{ \ - if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \ - { \ - struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ - GC_CHECK_NOT_FREE (lheader); \ - } \ -} while (0) -#else -#define KKCC_DO_CHECK_FREE(obj, allow_free) -#endif - -#ifdef ERROR_CHECK_GC -#ifdef DEBUG_XEMACS -static void -mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free, - int level, int pos) -#else -static void -mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free) -#endif -{ - KKCC_DO_CHECK_FREE (obj, allow_free); - kkcc_gc_stack_push_lisp_object (obj, level, pos); -} - -#ifdef DEBUG_XEMACS -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - mark_object_maybe_checking_free_1 (obj, allow_free, level, pos) -#else -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - mark_object_maybe_checking_free_1 (obj, allow_free) -#endif -#else /* not ERROR_CHECK_GC */ -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - kkcc_gc_stack_push_lisp_object (obj, level, pos) -#endif /* not ERROR_CHECK_GC */ - - -/* This function loops all elements of a struct pointer and calls - mark_with_description with each element. */ -static void -#ifdef DEBUG_XEMACS -mark_struct_contents_1 (const void *data, - const struct sized_memory_description *sdesc, - int count, int level, int pos) -#else -mark_struct_contents_1 (const void *data, - const struct sized_memory_description *sdesc, - int count) -#endif -{ - int i; - Bytecount elsize; - elsize = lispdesc_block_size (data, sdesc); - - for (i = 0; i < count; i++) - { - kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description, - level, pos); - } -} - -#ifdef DEBUG_XEMACS -#define mark_struct_contents(data, sdesc, count, level, pos) \ - mark_struct_contents_1 (data, sdesc, count, level, pos) -#else -#define mark_struct_contents(data, sdesc, count, level, pos) \ - mark_struct_contents_1 (data, sdesc, count) -#endif - -/* This function implements the KKCC mark algorithm. - Instead of calling mark_object, all the alive Lisp_Objects are pushed - on the kkcc_gc_stack. This function processes all elements on the stack - according to their descriptions. */ -static void -kkcc_marking (void) -{ - kkcc_gc_stack_entry *stack_entry = 0; - void *data = 0; - const struct memory_description *desc = 0; - int pos; -#ifdef DEBUG_XEMACS - int level = 0; - kkcc_bt_init (); -#endif - - while ((stack_entry = kkcc_gc_stack_pop ()) != 0) - { - data = stack_entry->data; - desc = stack_entry->desc; -#ifdef DEBUG_XEMACS - level = stack_entry->level + 1; -#endif - - kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos); - - gc_checking_assert (data); - gc_checking_assert (desc); - - for (pos = 0; desc[pos].type != XD_END; pos++) - { - const struct memory_description *desc1 = &desc[pos]; - const void *rdata = - (const char *) data + lispdesc_indirect_count (desc1->offset, - desc, data); - union_switcheroo: - - /* If the flag says don't mark, then don't mark. */ - if ((desc1->flags) & XD_FLAG_NO_KKCC) - continue; - - switch (desc1->type) - { - case XD_BYTECOUNT: - case XD_ELEMCOUNT: - case XD_HASHCODE: - case XD_INT: - case XD_LONG: - case XD_INT_RESET: - case XD_LO_LINK: - case XD_OPAQUE_PTR: - case XD_OPAQUE_DATA_PTR: - case XD_ASCII_STRING: - case XD_DOC_STRING: - break; - case XD_LISP_OBJECT: - { - const Lisp_Object *stored_obj = (const Lisp_Object *) rdata; - - /* Because of the way that tagged objects work (pointers and - Lisp_Objects have the same representation), XD_LISP_OBJECT - can be used for untagged pointers. They might be NULL, - though. */ - if (EQ (*stored_obj, Qnull_pointer)) - break; -#ifdef MC_ALLOC - mark_object_maybe_checking_free (*stored_obj, 0, level, pos); -#else /* not MC_ALLOC */ - mark_object_maybe_checking_free - (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, - level, pos); -#endif /* not MC_ALLOC */ - break; - } - case XD_LISP_OBJECT_ARRAY: - { - int i; - EMACS_INT count = - lispdesc_indirect_count (desc1->data1, desc, data); - - for (i = 0; i < count; i++) - { - const Lisp_Object *stored_obj = - (const Lisp_Object *) rdata + i; - - if (EQ (*stored_obj, Qnull_pointer)) - break; -#ifdef MC_ALLOC - mark_object_maybe_checking_free (*stored_obj, 0, level, pos); -#else /* not MC_ALLOC */ - mark_object_maybe_checking_free - (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, - level, pos); -#endif /* not MC_ALLOC */ - } - break; - } - case XD_BLOCK_PTR: - { - EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, - data); - const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2.descr); - const char *dobj = * (const char **) rdata; - if (dobj) - mark_struct_contents (dobj, sdesc, count, level, pos); - break; - } - case XD_BLOCK_ARRAY: - { - EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, - data); - const struct sized_memory_description *sdesc = - lispdesc_indirect_description (data, desc1->data2.descr); - - mark_struct_contents (rdata, sdesc, count, level, pos); - break; - } - case XD_UNION: - case XD_UNION_DYNAMIC_SIZE: - desc1 = lispdesc_process_xd_union (desc1, desc, data); - if (desc1) - goto union_switcheroo; - break; - - default: - stderr_out ("Unsupported description type : %d\n", desc1->type); - kkcc_backtrace (); - ABORT (); - } - } - } -#ifdef DEBUG_XEMACS - kkcc_bt_free (); -#endif -} -#endif /* USE_KKCC */ - -/* Mark reference to a Lisp_Object. If the object referred to has not been - seen yet, recursively mark all the references contained in it. */ - -void -mark_object ( -#ifdef USE_KKCC - Lisp_Object UNUSED (obj) -#else - Lisp_Object obj -#endif - ) -{ -#ifdef USE_KKCC - /* this code should never be reached when configured for KKCC */ - stderr_out ("KKCC: Invalid mark_object call.\n"); - stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n"); - ABORT (); -#else /* not USE_KKCC */ - - tail_recurse: - - /* Checks we used to perform */ - /* if (EQ (obj, Qnull_pointer)) return; */ - /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ - /* if (PURIFIED (XPNTR (obj))) return; */ - - if (XTYPE (obj) == Lisp_Type_Record) - { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - - GC_CHECK_LHEADER_INVARIANTS (lheader); - - /* We handle this separately, above, so we can mark free objects */ - GC_CHECK_NOT_FREE (lheader); - - /* All c_readonly objects have their mark bit set, - so that we only need to check the mark bit here. */ - if (! MARKED_RECORD_HEADER_P (lheader)) - { - MARK_RECORD_HEADER (lheader); - - if (RECORD_MARKER (lheader)) - { - obj = RECORD_MARKER (lheader) (obj); - if (!NILP (obj)) goto tail_recurse; - } - } - } -#endif /* not KKCC */ -} - - -#ifndef MC_ALLOC -static int gc_count_num_short_string_in_use; -static Bytecount gc_count_string_total_size; -static Bytecount gc_count_short_string_total_size; - -/* static int gc_count_total_records_used, gc_count_records_total_size; */ - - -/* stats on lcrecords in use - kinda kludgy */ - -static struct -{ - int instances_in_use; - int bytes_in_use; - int instances_freed; - int bytes_freed; - int instances_on_free_list; -} lcrecord_stats [countof (lrecord_implementations_table) - + MODULE_DEFINABLE_TYPE_COUNT]; - -static void -tick_lcrecord_stats (const struct lrecord_header *h, int free_p) -{ - int type_index = h->type; - - if (((struct old_lcrecord_header *) h)->free) - { - gc_checking_assert (!free_p); - lcrecord_stats[type_index].instances_on_free_list++; - } - else - { - Bytecount sz = detagged_lisp_object_size (h); - - if (free_p) - { - lcrecord_stats[type_index].instances_freed++; - lcrecord_stats[type_index].bytes_freed += sz; - } - else - { - lcrecord_stats[type_index].instances_in_use++; - lcrecord_stats[type_index].bytes_in_use += sz; - } - } -} -#endif /* not MC_ALLOC */ - - -#ifndef MC_ALLOC -/* Free all unmarked records */ -static void -sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used) -{ - struct old_lcrecord_header *header; - int num_used = 0; - /* int total_size = 0; */ - - xzero (lcrecord_stats); /* Reset all statistics to 0. */ - - /* First go through and call all the finalize methods. - Then go through and free the objects. There used to - be only one loop here, with the call to the finalizer - occurring directly before the xfree() below. That - is marginally faster but much less safe -- if the - finalize method for an object needs to reference any - other objects contained within it (and many do), - we could easily be screwed by having already freed that - other object. */ - - for (header = *prev; header; header = header->next) - { - struct lrecord_header *h = &(header->lheader); - - GC_CHECK_LHEADER_INVARIANTS (h); - - if (! MARKED_RECORD_HEADER_P (h) && ! header->free) - { - if (LHEADER_IMPLEMENTATION (h)->finalizer) - LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); - } - } - - for (header = *prev; header; ) - { - struct lrecord_header *h = &(header->lheader); - if (MARKED_RECORD_HEADER_P (h)) - { - if (! C_READONLY_RECORD_HEADER_P (h)) - UNMARK_RECORD_HEADER (h); - num_used++; - /* total_size += n->implementation->size_in_bytes (h);*/ - /* #### May modify header->next on a C_READONLY lcrecord */ - prev = &(header->next); - header = *prev; - tick_lcrecord_stats (h, 0); - } - else - { - struct old_lcrecord_header *next = header->next; - *prev = next; - tick_lcrecord_stats (h, 1); - /* used to call finalizer right here. */ - xfree (header, struct old_lcrecord_header *); - header = next; - } - } - *used = num_used; - /* *total = total_size; */ -} - /* And the Lord said: Thou shalt use the `c-backslash-region' command to make macros prettier. */ ＠＠ -4795,9 +4100,10 ＠＠ verify_string_chars_integrity (void) #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ +#ifndef NEW_GC /* Compactify string chars, relocating the reference to each -- free any empty string_chars_block we see. */ -static void +void compact_string_chars (void) { struct string_chars_block *to_sb = first_string_chars_block; ＠＠ -4893,6 +4199,7 ＠＠ compact_string_chars (void) current_string_chars_block->next = 0; } } +#endif /* not NEW_GC */ #ifndef MC_ALLOC #if 1 /* Hack to debug missing purecopy's */ ＠＠ -4953,29 +4260,10 ＠＠ sweep_strings (void) gc_count_short_string_total_size = num_small_bytes; } #endif /* not MC_ALLOC */ - -/* I hate duplicating all this crap! */ -int -marked_p (Lisp_Object obj) -{ - /* Checks we used to perform. */ - /* if (EQ (obj, Qnull_pointer)) return 1; */ - /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ - /* if (PURIFIED (XPNTR (obj))) return 1; */ - - if (XTYPE (obj) == Lisp_Type_Record) - { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - - GC_CHECK_LHEADER_INVARIANTS (lheader); - - return MARKED_RECORD_HEADER_P (lheader); - } - return 1; -} -static void -gc_sweep (void) +#ifndef NEW_GC +void +gc_sweep_1 (void) { #ifdef MC_ALLOC compact_string_chars (); ＠＠ -5064,6 +4352,7 ＠＠ gc_sweep (void) #endif #endif /* not MC_ALLOC */ } +#endif /* not NEW_GC */  /* Clearing for disksave. */ ＠＠ -5101,11 +4390,16 ＠＠ disksave_object_finalization (void) #endif Vshell_file_name = Qnil; +#ifdef NEW_GC + gc_full (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ /* Run the disksave finalization methods of all live objects. */ disksave_object_finalization_1 (); +#ifndef NEW_GC /* Zero out the uninitialized (really, unused) part of the containers for the live strings. */ { ＠＠ -5122,405 +4416,12 ＠＠ disksave_object_finalization (void) } } } +#endif /* not NEW_GC */ /* There, that ought to be enough... */ } - -int -begin_gc_forbidden (void) -{ - return internal_bind_int (&gc_currently_forbidden, 1); -} - -void -end_gc_forbidden (int count) -{ - unbind_to (count); -} - -/* Maybe we want to use this when doing a "panic" gc after memory_full()? */ -static int gc_hooks_inhibited; - -struct post_gc_action -{ - void (*fun) (void *); - void *arg; -}; - -typedef struct post_gc_action post_gc_action; - -typedef struct -{ - Dynarr_declare (post_gc_action); -} post_gc_action_dynarr; - -static post_gc_action_dynarr *post_gc_actions; - -/* Register an action to be called at the end of GC. - gc_in_progress is 0 when this is called. - This is used when it is discovered that an action needs to be taken, - but it's during GC, so it's not safe. (e.g. in a finalize method.) - - As a general rule, do not use Lisp objects here. - And NEVER signal an error. -*/ - -void -register_post_gc_action (void (*fun) (void *), void *arg) -{ - post_gc_action action; - - if (!post_gc_actions) - post_gc_actions = Dynarr_new (post_gc_action); - - action.fun = fun; - action.arg = arg; - - Dynarr_add (post_gc_actions, action); -} - -static void -run_post_gc_actions (void) -{ - int i; - - if (post_gc_actions) - { - for (i = 0; i < Dynarr_length (post_gc_actions); i++) - { - post_gc_action action = Dynarr_at (post_gc_actions, i); - (action.fun) (action.arg); - } - - Dynarr_reset (post_gc_actions); - } -} - - -void -garbage_collect_1 (void) -{ -#if MAX_SAVE_STACK > 0 - char stack_top_variable; - extern char *stack_bottom; -#endif - struct frame *f; - int speccount; - int cursor_changed; - Lisp_Object pre_gc_cursor; - struct gcpro gcpro1; - PROFILE_DECLARE (); - - assert (!in_display || gc_currently_forbidden); - - if (gc_in_progress - || gc_currently_forbidden - || in_display - || preparing_for_armageddon) - return; - - PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection); - - /* We used to call selected_frame() here. - - The following functions cannot be called inside GC - so we move to after the above tests. */ - { - Lisp_Object frame; - Lisp_Object device = Fselected_device (Qnil); - if (NILP (device)) /* Could happen during startup, eg. if always_gc */ - return; - frame = Fselected_frame (device); - if (NILP (frame)) - invalid_state ("No frames exist on device", device); - f = XFRAME (frame); - } - - pre_gc_cursor = Qnil; - cursor_changed = 0; - - GCPRO1 (pre_gc_cursor); - - /* Very important to prevent GC during any of the following - stuff that might run Lisp code; otherwise, we'll likely - have infinite GC recursion. */ - speccount = begin_gc_forbidden (); - - need_to_signal_post_gc = 0; - recompute_funcall_allocation_flag (); - - if (!gc_hooks_inhibited) - run_hook_trapping_problems - (Qgarbage_collecting, Qpre_gc_hook, - INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); - - /* Now show the GC cursor/message. */ - if (!noninteractive) - { - if (FRAME_WIN_P (f)) - { - Lisp_Object frame = wrap_frame (f); - Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph, - FRAME_SELECTED_WINDOW (f), - ERROR_ME_NOT, 1); - pre_gc_cursor = f->pointer; - if (POINTER_IMAGE_INSTANCEP (cursor) - /* don't change if we don't know how to change back. */ - && POINTER_IMAGE_INSTANCEP (pre_gc_cursor)) - { - cursor_changed = 1; - Fset_frame_pointer (frame, cursor); - } - } - - /* Don't print messages to the stream device. */ - if (!cursor_changed && !FRAME_STREAM_P (f)) - { - if (garbage_collection_messages) - { - Lisp_Object args[2], whole_msg; - args[0] = (STRINGP (Vgc_message) ? Vgc_message : - build_msg_string (gc_default_message)); - args[1] = build_string ("..."); - whole_msg = Fconcat (2, args); - echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1, - Qgarbage_collecting); - } - } - } - - /***** Now we actually start the garbage collection. */ - - gc_in_progress = 1; - inhibit_non_essential_conversion_operations = 1; - - gc_generation_number[0]++; - -#if MAX_SAVE_STACK > 0 - - /* Save a copy of the contents of the stack, for debugging. */ - if (!purify_flag) - { - /* Static buffer in which we save a copy of the C stack at each GC. */ - static char *stack_copy; - static Bytecount stack_copy_size; - - ptrdiff_t stack_diff = &stack_top_variable - stack_bottom; - Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff); - if (stack_size < MAX_SAVE_STACK) - { - if (stack_copy_size < stack_size) - { - stack_copy = (char *) xrealloc (stack_copy, stack_size); - stack_copy_size = stack_size; - } - - memcpy (stack_copy, - stack_diff > 0 ? stack_bottom : &stack_top_variable, - stack_size); - } - } -#endif /* MAX_SAVE_STACK > 0 */ - - /* Do some totally ad-hoc resource clearing. */ - /* #### generalize this? */ - clear_event_resource (); - cleanup_specifiers (); - cleanup_buffer_undo_lists (); - - /* Mark all the special slots that serve as the roots of accessibility. */ - -#ifdef USE_KKCC - /* initialize kkcc stack */ - kkcc_gc_stack_init(); -#define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) -#endif /* USE_KKCC */ - - { /* staticpro() */ - Lisp_Object **p = Dynarr_begin (staticpros); - Elemcount count; - for (count = Dynarr_length (staticpros); count; count--) - mark_object (**p++); - } - - { /* staticpro_nodump() */ - Lisp_Object **p = Dynarr_begin (staticpros_nodump); - Elemcount count; - for (count = Dynarr_length (staticpros_nodump); count; count--) - mark_object (**p++); - } - -#ifdef MC_ALLOC - { /* mcpro () */ - Lisp_Object *p = Dynarr_begin (mcpros); - Elemcount count; - for (count = Dynarr_length (mcpros); count; count--) - mark_object (*p++); - } -#endif /* MC_ALLOC */ - - { /* GCPRO() */ - struct gcpro *tail; - int i; - for (tail = gcprolist; tail; tail = tail->next) - for (i = 0; i < tail->nvars; i++) - mark_object (tail->var[i]); - } - - { /* specbind() */ - struct specbinding *bind; - for (bind = specpdl; bind != specpdl_ptr; bind++) - { - mark_object (bind->symbol); - mark_object (bind->old_value); - } - } - - { - struct catchtag *c; - for (c = catchlist; c; c = c->next) - { - mark_object (c->tag); - mark_object (c->val); - mark_object (c->actual_tag); - mark_object (c->backtrace); - } - } - - { - struct backtrace *backlist; - for (backlist = backtrace_list; backlist; backlist = backlist->next) - { - int nargs = backlist->nargs; - int i; - - mark_object (*backlist->function); - if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */ - /* might be fake (internal profiling entry) */ - && backlist->args) - mark_object (backlist->args[0]); - else - for (i = 0; i < nargs; i++) - mark_object (backlist->args[i]); - } - } - - mark_profiling_info (); - - /* OK, now do the after-mark stuff. This is for things that - are only marked when something else is marked (e.g. weak hash tables). - There may be complex dependencies between such objects -- e.g. - a weak hash table might be unmarked, but after processing a later - weak hash table, the former one might get marked. So we have to - iterate until nothing more gets marked. */ -#ifdef USE_KKCC - kkcc_marking (); -#endif /* USE_KKCC */ - init_marking_ephemerons (); - while (finish_marking_weak_hash_tables () > 0 || - finish_marking_weak_lists () > 0 || - continue_marking_ephemerons () > 0) -#ifdef USE_KKCC - { - kkcc_marking (); - } -#else /* NOT USE_KKCC */ - ; -#endif /* USE_KKCC */ - - /* At this point, we know which objects need to be finalized: we - still need to resurrect them */ - - while (finish_marking_ephemerons () > 0 || - finish_marking_weak_lists () > 0 || - finish_marking_weak_hash_tables () > 0) -#ifdef USE_KKCC - { - kkcc_marking (); - } - kkcc_gc_stack_free (); -#undef mark_object -#else /* NOT USE_KKCC */ - ; -#endif /* USE_KKCC */ - - /* And prune (this needs to be called after everything else has been - marked and before we do any sweeping). */ - /* #### this is somewhat ad-hoc and should probably be an object - method */ - prune_weak_hash_tables (); - prune_weak_lists (); - prune_specifiers (); - prune_syntax_tables (); - - prune_ephemerons (); - prune_weak_boxes (); - - gc_sweep (); - - consing_since_gc = 0; -#ifndef DEBUG_XEMACS - /* Allow you to set it really fucking low if you really want ... */ - if (gc_cons_threshold < 10000) - gc_cons_threshold = 10000; -#endif - recompute_need_to_garbage_collect (); - - inhibit_non_essential_conversion_operations = 0; - gc_in_progress = 0; - - run_post_gc_actions (); - - /******* End of garbage collection ********/ - - /* Now remove the GC cursor/message */ - if (!noninteractive) - { - if (cursor_changed) - Fset_frame_pointer (wrap_frame (f), pre_gc_cursor); - else if (!FRAME_STREAM_P (f)) - { - /* Show "...done" only if the echo area would otherwise be empty. */ - if (NILP (clear_echo_area (selected_frame (), - Qgarbage_collecting, 0))) - { - if (garbage_collection_messages) - { - Lisp_Object args[2], whole_msg; - args[0] = (STRINGP (Vgc_message) ? Vgc_message : - build_msg_string (gc_default_message)); - args[1] = build_msg_string ("... done"); - whole_msg = Fconcat (2, args); - echo_area_message (selected_frame (), (Ibyte *) 0, - whole_msg, 0, -1, - Qgarbage_collecting); - } - } - } - } - - /* now stop inhibiting GC */ - unbind_to (speccount); - -#ifndef MC_ALLOC - if (!breathing_space) - { - breathing_space = malloc (4096 - MALLOC_OVERHEAD); - } -#endif /* not MC_ALLOC */ - - UNGCPRO; - - need_to_signal_post_gc = 1; - funcall_allocation_flag = 1; - - PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); - - return; -} - #ifdef ALLOC_TYPE_STATS static Lisp_Object ＠＠ -5573,13 +4474,6 ＠＠ object_memory_usage_stats (int set_total pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); } } - pl = gc_plist_hack ("string-data-storage-including-overhead", - lrecord_string_data_bytes_in_use_including_overhead, pl); - pl = gc_plist_hack ("string-data-storage-additional", - lrecord_string_data_bytes_in_use, pl); - pl = gc_plist_hack ("string-data-used", - lrecord_string_data_instances_in_use, pl); - tgu_val += lrecord_string_data_bytes_in_use_including_overhead; #else /* not MC_ALLOC */ ＠＠ -5720,7 +4614,11 ＠＠ Garbage collection happens automatically ()) { /* Record total usage for purposes of determining next GC */ +#ifdef NEW_GC + gc_full (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ /* This will get set to 1, and total_gc_usage computed, as part of the call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */ ＠＠ -5819,28 +4717,6 ＠＠ recompute_funcall_allocation_flag (void) need_to_signal_post_gc; } -/* True if it's time to garbage collect now. */ -static void -recompute_need_to_garbage_collect (void) -{ - if (always_gc) - need_to_garbage_collect = 1; - else - need_to_garbage_collect = - (consing_since_gc > gc_cons_threshold - && -#if 0 /* #### implement this better */ - (100 * consing_since_gc) / total_data_usage () >= - gc_cons_percentage -#else - (!total_gc_usage_set || - (100 * consing_since_gc) / total_gc_usage >= - gc_cons_percentage) -#endif - ); - recompute_funcall_allocation_flag (); -} -  int object_dead_p (Lisp_Object obj) ＠＠ -6007,11 +4883,9 ＠＠ common_init_alloc_early (void) Qnull_pointer = wrap_pointer_1 (0); #endif - gc_generation_number[0] = 0; #ifndef MC_ALLOC breathing_space = 0; #endif /* not MC_ALLOC */ - Vgc_message = Qzero; #ifndef MC_ALLOC all_lcrecords = 0; #endif /* not MC_ALLOC */ ＠＠ -6023,7 +4897,9 ＠＠ common_init_alloc_early (void) mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ #endif #endif +#ifndef NEW_GC init_string_chars_alloc (); +#endif /* not NEW_GC */ #ifndef MC_ALLOC init_string_alloc (); init_string_chars_alloc (); ＠＠ -6081,26 +4957,15 ＠＠ common_init_alloc_early (void) #endif /* MC_ALLOC */ consing_since_gc = 0; - need_to_garbage_collect = always_gc; need_to_check_c_alloca = 0; funcall_allocation_flag = 0; funcall_alloca_count = 0; -#if 1 - gc_cons_threshold = 2000000; /* XEmacs change */ -#else - gc_cons_threshold = 15000; /* debugging */ -#endif - gc_cons_percentage = 40; /* #### what is optimal? */ - total_gc_usage_set = 0; lrecord_uid_counter = 259; #ifndef MC_ALLOC debug_string_purity = 0; #endif /* not MC_ALLOC */ - gc_currently_forbidden = 0; - gc_hooks_inhibited = 0; - #ifdef ERROR_CHECK_TYPES ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 666; ＠＠ -6167,6 +5032,10 ＠＠ init_alloc_once_early (void) INIT_LRECORD_IMPLEMENTATION (cons); INIT_LRECORD_IMPLEMENTATION (vector); INIT_LRECORD_IMPLEMENTATION (string); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (string_indirect_data); + INIT_LRECORD_IMPLEMENTATION (string_direct_data); +#endif /* NEW_GC */ #ifndef MC_ALLOC INIT_LRECORD_IMPLEMENTATION (lcrecord_list); INIT_LRECORD_IMPLEMENTATION (free); ＠＠ -6200,8 +5069,6 ＠＠ init_alloc_once_early (void) void syms_of_alloc (void) { - DEFSYMBOL (Qpre_gc_hook); - DEFSYMBOL (Qpost_gc_hook); DEFSYMBOL (Qgarbage_collecting); DEFSUBR (Fcons); ＠＠ -6232,49 +5099,6 ＠＠ syms_of_alloc (void) void vars_of_alloc (void) { - QSin_garbage_collection = build_msg_string ("(in garbage collection)"); - staticpro (&QSin_garbage_collection); - - DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /* -*Number of bytes of consing between garbage collections. -\"Consing\" is a misnomer in that this actually counts allocation -of all different kinds of objects, not just conses. -Garbage collection can happen automatically once this many bytes have been -allocated since the last garbage collection. All data types count. - -Garbage collection happens automatically when `eval' or `funcall' are -called. (Note that `funcall' is called implicitly as part of evaluation.) -By binding this temporarily to a large number, you can effectively -prevent garbage collection during a part of the program. - -Normally, you cannot set this value less than 10,000 (if you do, it is -automatically reset during the next garbage collection). However, if -XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing -you to set this value very low to track down problems with insufficient -GCPRO'ing. If you set this to a negative number, garbage collection will -happen at *EVERY* call to `eval' or `funcall'. This is an extremely -effective way to check GCPRO problems, but be warned that your XEmacs -will be unusable! You almost certainly won't have the patience to wait -long enough to be able to set it back. - -See also `consing-since-gc' and `gc-cons-percentage'. -*/ ); - - DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /* -*Percentage of memory allocated between garbage collections. - -Garbage collection will happen if this percentage of the total amount of -memory used for data (see `lisp-object-memory-usage') has been allocated -since the last garbage collection. However, it will not happen if less -than `gc-cons-threshold' bytes have been allocated -- this sets an absolute -minimum in case very little data has been allocated or the percentage is -set very low. Set this to 0 to have garbage collection always happen after -`gc-cons-threshold' bytes have been allocated, regardless of current memory -usage. - -See also `consing-since-gc' and `gc-cons-threshold'. -*/ ); - #ifdef DEBUG_XEMACS DEFVAR_INT ("debug-allocation", &debug_allocation /* If non-zero, print out information to stderr about all objects allocated. ＠＠ -6293,49 +5117,4 ＠＠ Length (in stack frames) of short backtr Non-nil means loading Lisp code in order to dump an executable. This means that certain objects should be allocated in readonly space. */ ); - - DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /* - Non-nil means display messages at start and end of garbage collection. -*/ ); - garbage_collection_messages = 0; - - DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /* -Function or functions to be run just before each garbage collection. -Interrupts, garbage collection, and errors are inhibited while this hook -runs, so be extremely careful in what you add here. In particular, avoid -consing, and do not interact with the user. -*/ ); - Vpre_gc_hook = Qnil; - - DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /* -Function or functions to be run just after each garbage collection. -Interrupts, garbage collection, and errors are inhibited while this hook -runs. Each hook is called with one argument which is an alist with -finalization data. -*/ ); - Vpost_gc_hook = Qnil; - - DEFVAR_LISP ("gc-message", &Vgc_message /* -String to print to indicate that a garbage collection is in progress. -This is printed in the echo area. If the selected frame is on a -window system and `gc-pointer-glyph' specifies a value (i.e. a pointer -image instance) in the domain of the selected frame, the mouse pointer -will change instead of this message being printed. -*/ ); - Vgc_message = build_string (gc_default_message); - - DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* -Pointer glyph used to indicate that a garbage collection is in progress. -If the selected window is on a window system and this glyph specifies a -value (i.e. a pointer image instance) in the domain of the selected -window, the pointer will be changed as specified during garbage collection. -Otherwise, a message will be printed in the echo area, as controlled -by `gc-message'. -*/ ); -} - -void -complex_vars_of_alloc (void) -{ - Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); } 1.74 +17 -0 XEmacs/xemacs/src/buffer.c Index: buffer.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/buffer.c,v retrieving revision 1.73 retrieving revision 1.74 diff -u -p -r1.73 -r1.74 --- buffer.c 2005/10/25 08:32:47 1.73 +++ buffer.c 2005/11/25 01:41:56 1.74 ＠＠ -233,6 +233,14 ＠＠ static const struct memory_description b { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("buffer-text", buffer_text, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + buffer_text_description_1, + Lisp_Buffer_Text); +#endif /* NEW_GC */ + static const struct sized_memory_description buffer_text_description = { sizeof (struct buffer_text), buffer_text_description_1 ＠＠ -244,10 +252,16 ＠＠ static const struct memory_description b { XD_LISP_OBJECT, offsetof (struct buffer, extent_info) }, +#ifdef NEW_GC + { XD_BLOCK_PTR, offsetof (struct buffer, text), + 1, { &buffer_text_description } }, + { XD_LISP_OBJECT, offsetof (struct buffer, syntax_cache) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (struct buffer, text), 1, { &buffer_text_description } }, { XD_BLOCK_PTR, offsetof (struct buffer, syntax_cache), 1, { &syntax_cache_description } }, +#endif /* not NEW_GC */ { XD_LISP_OBJECT, offsetof (struct buffer, indirect_children) }, { XD_LISP_OBJECT, offsetof (struct buffer, base_buffer) }, ＠＠ -1889,6 +1903,9 ＠＠ void syms_of_buffer (void) { INIT_LRECORD_IMPLEMENTATION (buffer); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (buffer_text); +#endif /* NEW_GC */ DEFSYMBOL (Qbuffer_live_p); DEFSYMBOL (Qbuffer_or_string_p); 1.34 +17 -0 XEmacs/xemacs/src/buffer.h Index: buffer.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/buffer.h,v retrieving revision 1.33 retrieving revision 1.34 diff -u -p -r1.33 -r1.34 --- buffer.h 2005/10/24 10:07:34 1.33 +++ buffer.h 2005/11/25 01:41:56 1.34 ＠＠ -79,6 +79,9 ＠＠ Boston, MA 02111-1307, USA. */ struct buffer_text { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Ibyte *beg; /* Actual address of buffer contents. */ Bytebpos gpt; /* Index of gap in buffer. */ Charbpos bufgpt; /* Equivalent as a Charbpos. */ ＠＠ -137,6 +140,20 ＠＠ struct buffer_text /* Change data that goes with the text. */ struct buffer_text_change_data *changes; }; + +#ifdef NEW_GC +typedef struct buffer_text Lisp_Buffer_Text; + +DECLARE_LRECORD (buffer_text, Lisp_Buffer_Text); + +#define XBUFFER_TEXT(x) \ + XRECORD (x, buffer_text, Lisp_Buffer_Text) +#define wrap_buffer_text(p) wrap_record (p, buffer_text) +#define BUFFER_TEXT_P(x) RECORDP (x, buffer_text) +#define CHECK_BUFFER_TEXT(x) CHECK_RECORD (x, buffer_text) +#define CONCHECK_BUFFER_TEXT(x) CONCHECK_RECORD (x, buffer_text) +#endif /* NEW_GC */ + struct buffer { 1.48 +64 -4 XEmacs/xemacs/src/bytecode.c Index: bytecode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/bytecode.c,v retrieving revision 1.47 retrieving revision 1.48 diff -u -p -r1.47 -r1.48 --- bytecode.c 2005/04/08 23:11:19 1.47 +++ bytecode.c 2005/11/25 01:41:56 1.48 ＠＠ -58,6 +58,45 ＠＠ by Hallvard: #include "syntax.h" #include "window.h" +#ifdef NEW_GC +static Lisp_Object +make_compiled_function_args (int totalargs) +{ + Lisp_Compiled_Function_Args *args; + args = (Lisp_Compiled_Function_Args *) + alloc_lrecord + (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, + Lisp_Object, args, totalargs), + &lrecord_compiled_function_args); + args->size = totalargs; + return wrap_compiled_function_args (args); +} + +static Bytecount +size_compiled_function_args (const void *lheader) +{ + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, + Lisp_Object, args, + ((Lisp_Compiled_Function_Args *) + lheader)->size); +} + +static const struct memory_description compiled_function_args_description[] = { + { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) }, + { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args), + XD_INDIRECT(0, 0) }, + { XD_END } +}; + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("compiled-function-args", + compiled_function_args, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + compiled_function_args_description, + size_compiled_function_args, + Lisp_Compiled_Function_Args); +#endif /* NEW_GC */ + EXFUN (Ffetch_bytecode, 1); Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; ＠＠ -2022,13 +2061,21 ＠＠ optimize_compiled_function (Lisp_Object } if (totalargs) +#ifdef NEW_GC + f->arguments = make_compiled_function_args (totalargs); +#else /* not NEW_GC */ f->args = xnew_array (Lisp_Object, totalargs); +#endif /* not NEW_GC */ { LIST_LOOP_2 (arg, f->arglist) { if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest)) +#ifdef NEW_GC + XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg; +#else /* not NEW_GC */ f->args[i++] = arg; +#endif /* not NEW_GC */ } } ＠＠ -2061,6 +2108,7 ＠＠ optimize_compiled_function (Lisp_Object /************************************************************************/ /* The compiled-function object type */ /************************************************************************/ + static void print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) ＠＠ -2143,7 +2191,11 ＠＠ mark_compiled_function (Lisp_Object obj) mark_object (f->annotated); #endif for (i = 0; i < f->args_in_array; i++) +#ifdef NEW_GC + mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]); +#else /* not NEW_GC */ mark_object (f->args[i]); +#endif /* not NEW_GC */ /* tail-recurse on constants */ return f->constants; ＠＠ -2179,8 +2231,12 ＠＠ compiled_function_hash (Lisp_Object obj, static const struct memory_description compiled_function_description[] = { { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) }, - { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) }, +#else /* not NEW_GC */ + { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), XD_INDIRECT (0, 0), { &lisp_object_description } }, +#endif /* not NEW_GC */ { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) }, { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) }, { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) }, ＠＠ -2191,7 +2247,7 ＠＠ static const struct memory_description c { XD_END } }; -#ifdef MC_ALLOC +#if defined(MC_ALLOC) && !defined(NEW_GC) static void finalize_compiled_function (void *header, int for_disksave) { ＠＠ -2213,7 +2269,7 ＠＠ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("co compiled_function_hash, compiled_function_description, Lisp_Compiled_Function); -#else /* not MC_ALLOC */ +#else /* !MC_ALLOC || NEW_GC */ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, 1, /*dumpable_flag*/ mark_compiled_function, ＠＠ -2222,7 +2278,8 ＠＠ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("co compiled_function_hash, compiled_function_description, Lisp_Compiled_Function); -#endif /* not MC_ALLOC */ +#endif /* !MC_ALLOC || NEW_GC */ +  DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* Return t if OBJECT is a byte-compiled function object. ＠＠ -2594,6 +2651,9 ＠＠ void syms_of_bytecode (void) { INIT_LRECORD_IMPLEMENTATION (compiled_function); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (compiled_function_args); +#endif /* NEW_GC */ DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); DEFSYMBOL (Qbyte_code); 1.9 +30 -0 XEmacs/xemacs/src/bytecode.h Index: bytecode.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/bytecode.h,v retrieving revision 1.8 retrieving revision 1.9 diff -u -p -r1.8 -r1.9 --- bytecode.h 2002/04/14 12:42:14 1.8 +++ bytecode.h 2005/11/25 01:41:56 1.9 ＠＠ -31,6 +31,32 ＠＠ Boston, MA 02111-1307, USA. */ #ifndef INCLUDED_bytecode_h_ #define INCLUDED_bytecode_h_ +#ifdef NEW_GC +struct compiled_function_args +{ + struct lrecord_header header; + long size; + Lisp_Object args[1]; +}; + +typedef struct compiled_function_args Lisp_Compiled_Function_Args; + +DECLARE_LRECORD (compiled_function_args, Lisp_Compiled_Function_Args); + +#define XCOMPILED_FUNCTION_ARGS(x) \ + XRECORD (x, compiled_function_args, Lisp_Compiled_Function_Args) +#define wrap_compiled_function_args(p) wrap_record (p, compiled_function_args) +#define COMPILED_FUNCTION_ARGS_P(x) RECORDP (x, compiled_function_args) +#define CHECK_COMPILED_FUNCTION_ARGS(x) \ + CHECK_RECORD (x, compiled_function_args) +#define CONCHECK_COMPILED_FUNCTION_ARGS(x) \ + CONCHECK_RECORD (x, compiled_function_args) + +#define compiled_function_args_data(v) ((v)->args) +#define XCOMPILED_FUNCTION_ARGS_DATA(s) \ + compiled_function_args_data (XCOMPILED_FUNCTION_ARGS (s)) +#endif /* not NEW_GC */ + /* Meanings of slots in a Lisp_Compiled_Function. Don't use these! For backward compatibility only. */ #define COMPILED_ARGLIST 0 ＠＠ -64,7 +90,11 ＠＠ struct Lisp_Compiled_Function Lisp_Object arglist; /* For speed, we unroll arglist into an array of argument symbols, so we don't have to process arglist every time we make a function call. */ +#ifdef NEW_GC + Lisp_Object arguments; +#else /* not NEW_GC */ Lisp_Object *args; +#endif /* not NEW_GC */ /* Minimum and maximum number of arguments. If MAX_ARGS == MANY, the function was declared with &rest, and (args_in_array - 1) indicates how many arguments there are before the &rest argument. (We could 1.103 +17 -0 XEmacs/xemacs/src/config.h.in Index: config.h.in =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/config.h.in,v retrieving revision 1.102 retrieving revision 1.103 diff -u -p -r1.102 -r1.103 --- config.h.in 2005/10/25 11:19:58 1.102 +++ config.h.in 2005/11/25 01:41:56 1.103 ＠＠ -414,6 +414,14 ＠＠ things are arranged in config.h.in. In #undef HAVE_WCSCMP #undef HAVE_WCSLEN +/* Functions and structs checked for vdb. */ +#undef HAVE_MPROTECT +#undef HAVE_SIGACTION +#undef HAVE_STRUCT_SIGINFO_SI_ADDR +#undef HAVE_SIGINFO_T_SI_ADDR +#undef HAVE_SIGNAL +#undef HAVE_STRUCT_SIGCONTEXT_CR2 + #undef HAVE_UTIME #undef HAVE_UTIMES #undef HAVE_SIGSETJMP ＠＠ -680,6 +688,15 ＠＠ things are arranged in config.h.in. In /* If defined, use experimental allocator. */ #undef MC_ALLOC + +/* If defined, use experimental incremental garbage collector. */ +#undef NEW_GC + +/* Virtual dirty bit implementation for incremental gc. */ +#undef VDB_POSIX +#undef VDB_MACH +#undef VDB_WIN32 +#undef VDB_FAKE /* Enable special GNU Make features in the Makefiles. */ #undef USE_GNU_MAKE 1.6 +29 -0 XEmacs/xemacs/src/console-gtk-impl.h Index: console-gtk-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-gtk-impl.h,v retrieving revision 1.5 retrieving revision 1.6 diff -u -p -r1.5 -r1.6 --- console-gtk-impl.h 2004/07/07 12:01:06 1.5 +++ console-gtk-impl.h 2005/11/25 01:41:57 1.6 ＠＠ -49,6 +49,9 ＠＠ DECLARE_CONSOLE_TYPE (gtk); struct gtk_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ /* Gtk application info. */ GtkWidget *gtk_app_shell; ＠＠ -109,6 +112,17 ＠＠ struct gtk_device #endif }; +#ifdef NEW_GC +typedef struct gtk_device Lisp_Gtk_Device; + +DECLARE_LRECORD (gtk_device, Lisp_Gtk_Device); + +#define XGTK_DEVICE(x) \ + XRECORD (x, gtk_device, Lisp_Gtk_Device) +#define wrap_gtk_device(p) wrap_record (p, gtk_device) +#define GTK_DEVICE_P(x) RECORDP (x, gtk_device) +#endif /* NEW_GC */ + #define DEVICE_GTK_DATA(d) DEVICE_TYPE_DATA (d, gtk) #define DEVICE_GTK_VISUAL(d) (DEVICE_GTK_DATA (d)->visual) ＠＠ -129,6 +143,10 ＠＠ struct gtk_device struct gtk_frame { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ + /* The widget of this frame. */ GtkWidget *widget; /* This is really a GtkWindow */ ＠＠ -181,6 +199,17 ＠＠ struct gtk_frame Lisp_Object widget_callback_hash_table; Lisp_Object widget_callback_ex_hash_table; }; + +#ifdef NEW_GC +typedef struct gtk_frame Lisp_Gtk_Frame; + +DECLARE_LRECORD (gtk_frame, Lisp_Gtk_Frame); + +#define XGTK_FRAME(x) \ + XRECORD (x, gtk_frame, Lisp_Gtk_Frame) +#define wrap_gtk_frame(p) wrap_record (p, gtk_frame) +#define GTK_FRAME_P(x) RECORDP (x, gtk_frame) +#endif /* NEW_GC */ #define FRAME_GTK_DATA(f) FRAME_TYPE_DATA (f, gtk) 1.6 +43 -0 XEmacs/xemacs/src/console-msw-impl.h Index: console-msw-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-msw-impl.h,v retrieving revision 1.5 retrieving revision 1.6 diff -u -p -r1.5 -r1.6 --- console-msw-impl.h 2005/10/24 10:07:34 1.5 +++ console-msw-impl.h 2005/11/25 01:41:57 1.6 ＠＠ -81,6 +81,9 ＠＠ struct Lisp_Devmode struct mswindows_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Lisp_Object fontlist; /* List of (STRING . FIXED-P), device fonts */ HDC hcdc; /* Compatible DC */ DWORD update_tick; /* Used when device is modified through ＠＠ -88,6 +91,17 ＠＠ struct mswindows_device in event-msw.c */ }; +#ifdef NEW_GC +typedef struct mswindows_device Lisp_Mswindows_Device; + +DECLARE_LRECORD (mswindows_device, Lisp_Mswindows_Device); + +#define XMSWINDOWS_DEVICE(x) \ + XRECORD (x, mswindows_device, Lisp_Mswindows_Device) +#define wrap_mswindows_device(p) wrap_record (p, mswindows_device) +#define MSWINDOWS_DEVICE_P(x) RECORDP (x, mswindows_device) +#endif /* NEW_GC */ + #define DEVICE_MSWINDOWS_DATA(d) DEVICE_TYPE_DATA (d, mswindows) #define DEVICE_MSWINDOWS_FONTLIST(d) (DEVICE_MSWINDOWS_DATA (d)->fontlist) #define DEVICE_MSWINDOWS_HCDC(d) (DEVICE_MSWINDOWS_DATA (d)->hcdc) ＠＠ -95,6 +109,9 ＠＠ struct mswindows_device struct msprinter_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ HDC hdc, hcdc; /* Printer and the comp. DCs */ HANDLE hprinter; Lisp_Object name; ＠＠ -102,6 +119,17 ＠＠ struct msprinter_device Lisp_Object fontlist; }; +#ifdef NEW_GC +typedef struct msprinter_device Lisp_Msprinter_Device; + +DECLARE_LRECORD (msprinter_device, Lisp_Msprinter_Device); + +#define XMSPRINTER_DEVICE(x) \ + XRECORD (x, msprinter_device, Lisp_Msprinter_Device) +#define wrap_msprinter_device(p) wrap_record (p, msprinter_device) +#define MSPRINTER_DEVICE_P(x) RECORDP (x, msprinter_device) +#endif /* NEW_GC */ + #define DEVICE_MSPRINTER_DATA(d) DEVICE_TYPE_DATA (d, msprinter) #define DEVICE_MSPRINTER_HDC(d) (DEVICE_MSPRINTER_DATA (d)->hdc) #define DEVICE_MSPRINTER_HCDC(d) (DEVICE_MSPRINTER_DATA (d)->hcdc) ＠＠ -139,6 +167,10 ＠＠ struct msprinter_device struct mswindows_frame { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ + /* win32 window handle */ HWND hwnd; ＠＠ -198,6 +230,17 ＠＠ struct mswindows_frame creation. Members are set to -1 for unspecified */ XEMACS_RECT_WH *target_rect; }; + +#ifdef NEW_GC +typedef struct mswindows_frame Lisp_Mswindows_Frame; + +DECLARE_LRECORD (mswindows_frame, Lisp_Mswindows_Frame); + +#define XMSWINDOWS_FRAME(x) \ + XRECORD (x, mswindows_frame, Lisp_Mswindows_Frame) +#define wrap_mswindows_frame(p) wrap_record (p, mswindows_frame) +#define MSWINDOWS_FRAME_P(x) RECORDP (x, mswindows_frame) +#endif /* NEW_GC */ #define FRAME_MSWINDOWS_DATA(f) FRAME_TYPE_DATA (f, mswindows) 1.3 +14 -0 XEmacs/xemacs/src/console-stream-impl.h Index: console-stream-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-stream-impl.h,v retrieving revision 1.2 retrieving revision 1.3 diff -u -p -r1.2 -r1.3 --- console-stream-impl.h 2003/01/12 11:08:09 1.2 +++ console-stream-impl.h 2005/11/25 01:41:57 1.3 ＠＠ -34,12 +34,26 ＠＠ DECLARE_CONSOLE_TYPE (stream); struct stream_console { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ FILE *in; FILE *out; FILE *err; int needs_newline; Lisp_Object instream; }; + +#ifdef NEW_GC +typedef struct stream_console Lisp_Stream_Console; + +DECLARE_LRECORD (stream_console, Lisp_Stream_Console); + +#define XSTREAM_CONSOLE(x) \ + XRECORD (x, stream_console, Lisp_Stream_Console) +#define wrap_stream_console(p) wrap_record (p, stream_console) +#define STREAM_CONSOLE_P(x) RECORDP (x, stream_console) +#endif /* NEW_GC */ #define CONSOLE_STREAM_DATA(con) CONSOLE_TYPE_DATA (con, stream) 1.26 +18 -0 XEmacs/xemacs/src/console-stream.c Index: console-stream.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-stream.c,v retrieving revision 1.25 retrieving revision 1.26 diff -u -p -r1.25 -r1.26 --- console-stream.c 2005/01/24 23:33:48 1.25 +++ console-stream.c 2005/11/25 01:41:57 1.26 ＠＠ -53,9 +53,17 ＠＠ static const struct memory_description s { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("stream-console", stream_console, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + stream_console_data_description_1, + Lisp_Stream_Console); +#else /* not NEW_GC */ const struct sized_memory_description stream_console_data_description = { sizeof (struct stream_console), stream_console_data_description_1 }; +#endif /* not NEW_GC */ static void stream_init_console (struct console *con, Lisp_Object UNUSED (params)) ＠＠ -63,8 +71,14 ＠＠ stream_init_console (struct console *con Lisp_Object tty = CONSOLE_CONNECTION (con); struct stream_console *stream_con; +#ifdef NEW_GC if (CONSOLE_STREAM_DATA (con) == NULL) + CONSOLE_STREAM_DATA (con) = alloc_lrecord_type (struct stream_console, + &lrecord_stream_console); +#else /* not NEW_GC */ + if (CONSOLE_STREAM_DATA (con) == NULL) CONSOLE_STREAM_DATA (con) = xnew_and_zero (struct stream_console); +#endif /* not NEW_GC */ stream_con = CONSOLE_STREAM_DATA (con); ＠＠ -123,7 +137,11 ＠＠ stream_delete_console (struct console *c if (stream_con->in != stdin) retry_fclose (stream_con->in); +#ifdef NEW_GC + mc_free (stream_con); +#else /* not NEW_GC */ xfree (stream_con, struct stream_console *); +#endif /* not NEW_GC */ CONSOLE_STREAM_DATA (con) = NULL; } } 1.8 +2 -0 XEmacs/xemacs/src/console-stream.h Index: console-stream.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-stream.h,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- console-stream.h 2003/01/12 11:08:09 1.7 +++ console-stream.h 2005/11/25 01:41:57 1.8 ＠＠ -29,7 +29,9 ＠＠ Boston, MA 02111-1307, USA. */ #include "console.h" +#ifndef NEW_GC extern const struct sized_memory_description stream_console_data_description; +#endif /* not NEW_GC */ extern Lisp_Object Vterminal_console, Vterminal_frame, Vterminal_device; 1.2 +28 -0 XEmacs/xemacs/src/console-tty-impl.h Index: console-tty-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-tty-impl.h,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- console-tty-impl.h 2002/06/20 21:18:24 1.1 +++ console-tty-impl.h 2005/11/25 01:41:57 1.2 ＠＠ -39,6 +39,9 ＠＠ DECLARE_CONSOLE_TYPE (tty); struct tty_console { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ int infd, outfd; Lisp_Object instream, outstream; Lisp_Object terminal_type; ＠＠ -199,6 +202,17 ＠＠ struct tty_console unsigned int is_stdio :1; }; +#ifdef NEW_GC +typedef struct tty_console Lisp_Tty_Console; + +DECLARE_LRECORD (tty_console, Lisp_Tty_Console); + +#define XTTY_CONSOLE(x) \ + XRECORD (x, tty_console, Lisp_Tty_Console) +#define wrap_tty_console(p) wrap_record (p, tty_console) +#define TTY_CONSOLE_P(x) RECORDP (x, tty_console) +#endif /* NEW_GC */ + #define CONSOLE_TTY_DATA(c) CONSOLE_TYPE_DATA (c, tty) #define CONSOLE_TTY_CURSOR_X(c) (CONSOLE_TTY_DATA (c)->cursor_x) #define CONSOLE_TTY_CURSOR_Y(c) (CONSOLE_TTY_DATA (c)->cursor_y) ＠＠ -228,12 +242,26 ＠＠ struct tty_console struct tty_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ #ifdef HAVE_TERMIOS speed_t ospeed; /* Output speed (from sg_ospeed) */ #else short ospeed; /* Output speed (from sg_ospeed) */ #endif }; + +#ifdef NEW_GC +typedef struct tty_device Lisp_Tty_Device; + +DECLARE_LRECORD (tty_device, Lisp_Tty_Device); + +#define XTTY_DEVICE(x) \ + XRECORD (x, tty_device, Lisp_Tty_Device) +#define wrap_tty_device(p) wrap_record (p, tty_device) +#define TTY_DEVICE_P(x) RECORDP (x, tty_device) +#endif /* NEW_GC */ #define DEVICE_TTY_DATA(d) DEVICE_TYPE_DATA (d, tty) 1.34 +17 -0 XEmacs/xemacs/src/console-tty.c Index: console-tty.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-tty.c,v retrieving revision 1.33 retrieving revision 1.34 diff -u -p -r1.33 -r1.34 --- console-tty.c 2005/07/08 08:27:34 1.33 +++ console-tty.c 2005/11/25 01:41:58 1.34 ＠＠ -59,16 +59,29 ＠＠ static const struct memory_description t { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("tty-console", tty_console, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + tty_console_data_description_1, + Lisp_Tty_Console); +#else /* not NEW_GC */ const struct sized_memory_description tty_console_data_description = { sizeof (struct tty_console), tty_console_data_description_1 }; +#endif /* not NEW_GC */  static void allocate_tty_console_struct (struct console *con) { /* zero out all slots except the lisp ones ... */ +#ifdef NEW_GC + CONSOLE_TTY_DATA (con) = alloc_lrecord_type (struct tty_console, + &lrecord_tty_console); +#else /* not NEW_GC */ CONSOLE_TTY_DATA (con) = xnew_and_zero (struct tty_console); +#endif /* not NEW_GC */ CONSOLE_TTY_DATA (con)->terminal_type = Qnil; CONSOLE_TTY_DATA (con)->instream = Qnil; CONSOLE_TTY_DATA (con)->outstream = Qnil; ＠＠ -202,7 +215,11 ＠＠ free_tty_console_struct (struct console xfree (tty_con->term_entry_buffer, char *); tty_con->term_entry_buffer = NULL; } +#ifdef NEW_GC + mc_free (tty_con); +#else /* not NEW_GC */ xfree (tty_con, struct tty_console *); +#endif /* not NEW_GC */ CONSOLE_TTY_DATA (con) = NULL; } } 1.4 +28 -0 XEmacs/xemacs/src/console-x-impl.h Index: console-x-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console-x-impl.h,v retrieving revision 1.3 retrieving revision 1.4 diff -u -p -r1.3 -r1.4 --- console-x-impl.h 2004/11/04 23:06:18 1.3 +++ console-x-impl.h 2005/11/25 01:41:58 1.4 ＠＠ -42,6 +42,9 ＠＠ DECLARE_CONSOLE_TYPE (x); struct x_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ /* The X connection of this device. */ Display *display; ＠＠ -159,6 +162,17 ＠＠ struct x_device Time modifier_release_time; }; +#ifdef NEW_GC +typedef struct x_device Lisp_X_Device; + +DECLARE_LRECORD (x_device, Lisp_X_Device); + +#define XX_DEVICE(x) \ + XRECORD (x, x_device, Lisp_X_Device) +#define wrap_x_device(p) wrap_record (p, x_device) +#define X_DEVICE_P(x) RECORDP (x, x_device) +#endif /* NEW_GC */ + #define DEVICE_X_DATA(d) DEVICE_TYPE_DATA (d, x) #define FRAME_X_DISPLAY(f) (DEVICE_X_DISPLAY (XDEVICE (f->device))) ＠＠ -225,6 +239,10 ＠＠ struct x_device struct x_frame { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ + /* The widget of this frame. This is an EmacsShell or an ExternalShell. */ Widget widget; ＠＠ -311,6 +329,16 ＠＠ struct x_frame #endif /* EXTERNAL_WIDGET */ }; +#ifdef NEW_GC +typedef struct x_frame Lisp_X_Frame; + +DECLARE_LRECORD (x_frame, Lisp_X_Frame); + +#define XX_FRAME(x) \ + XRECORD (x, x_frame, Lisp_X_Frame) +#define wrap_x_frame(p) wrap_record (p, x_frame) +#define X_FRAME_P(x) RECORDP (x, x_frame) +#endif /* NEW_GC */ #define FRAME_X_DATA(f) FRAME_TYPE_DATA (f, x) #define FRAME_X_SHELL_WIDGET(f) (FRAME_X_DATA (f)->widget) 1.45 +14 -0 XEmacs/xemacs/src/console.c Index: console.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/console.c,v retrieving revision 1.44 retrieving revision 1.45 diff -u -p -r1.44 -r1.45 --- console.c 2005/10/25 11:16:21 1.44 +++ console.c 2005/11/25 01:41:58 1.45 ＠＠ -115,9 +115,17 ＠＠ console_type_entry_dynarr *the_console_t static const struct memory_description console_data_description_1 []= { #ifdef HAVE_TTY +#ifdef NEW_GC + { XD_LISP_OBJECT, tty_console }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, tty_console, 1, { &tty_console_data_description} }, +#endif /* not NEW_GC */ #endif +#ifdef NEW_GC + { XD_LISP_OBJECT, stream_console }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, stream_console, 1, { &stream_console_data_description} }, +#endif /* not NEW_GC */ { XD_END } }; ＠＠ -1189,6 +1197,12 ＠＠ void syms_of_console (void) { INIT_LRECORD_IMPLEMENTATION (console); +#ifdef NEW_GC +#ifdef HAVE_TTY + INIT_LRECORD_IMPLEMENTATION (tty_console); +#endif + INIT_LRECORD_IMPLEMENTATION (stream_console); +#endif /* not NEW_GC */ DEFSUBR (Fvalid_console_type_p); DEFSUBR (Fconsole_type_list); 1.59 +8 -2 XEmacs/xemacs/src/depend Index: depend =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/depend,v retrieving revision 1.58 retrieving revision 1.59 diff -u -p -r1.58 -r1.59 --- depend 2005/10/04 21:51:35 1.58 +++ depend 2005/11/25 01:41:58 1.59 ＠＠ -11,7 +11,7 ＠＠ CONFIG_H= LISP_H= #else CONFIG_H=config.h -LISP_H=lisp.h compiler.h config.h dumper.h general-slots.h lrecord.h mc-alloc.h number-gmp.h number-mp.h number.h symeval.h symsinit.h text.h $(LISP_UNION_H) +LISP_H=lisp.h compiler.h config.h dumper.h gc.h general-slots.h lisp.h lrecord.h mc-alloc.h number-gmp.h number-mp.h number.h symeval.h symsinit.h text.h vdb.h $(LISP_UNION_H) #endif #if defined(HAVE_MS_WINDOWS) ＠＠ -152,6 +152,7 ＠＠ fns.o: $(LISP_H) buffer.h bufslots.h byt font-lock.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h insdel.h syntax.h frame.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h events.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gui.h gutter.h menubar.h process.h redisplay.h scrollbar.h specifier.h systime.h toolbar.h window-impl.h window.h winslots.h free-hook.o: $(LISP_H) hash.h +gc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-stream.h console.h device.h elhash.h events.h extents-impl.h extents.h file-coding.h frame-impl.h frame.h frameslots.h glyphs.h lstream.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h systime.h window-impl.h window.h winslots.h general.o: $(LISP_H) general-slots.h getloadavg.o: $(LISP_H) sysfile.h syssignal.h gif_io.o: $(LISP_H) gifrlib.h sysfile.h ＠＠ -187,7 +188,7 ＠＠ lstream.o: $(LISP_H) buffer.h bufslots.h macros.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console.h device.h events.h frame.h keymap.h macros.h redisplay.h scrollbar.h systime.h window.h malloc.o: $(CONFIG_H) getpagesize.h syssignal.h marker.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h -mc-alloc.o: $(LISP_H) +mc-alloc.o: $(LISP_H) blocktype.h getpagesize.h md5.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h file-coding.h lstream.h menubar.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h frame-impl.h frame.h frameslots.h gui.h keymap.h menubar.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h minibuf.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console-stream.h console.h events.h frame-impl.h frame.h frameslots.h insdel.h redisplay.h scrollbar.h systime.h window-impl.h window.h winslots.h ＠＠ -261,6 +262,11 ＠＠ unexsol2-6.o: compiler.h unexsol2.o: compiler.h unexsunos4.o: $(CONFIG_H) compiler.h unicode.o: $(LISP_H) charset.h coding-system-slots.h file-coding.h opaque.h sysfile.h +vdb-fake.o: $(LISP_H) +vdb-mach.o: $(LISP_H) +vdb-posix.o: $(LISP_H) +vdb-win32.o: $(LISP_H) intl-auto-encap-win32.h syswindows.h +vdb.o: $(LISP_H) vm-limit.o: $(LISP_H) mem-limits.h widget.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h win32.o: $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h console-msw.h console.h hash.h intl-auto-encap-win32.h profile.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h 1.16 +20 -0 XEmacs/xemacs/src/device-gtk.c Index: device-gtk.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device-gtk.c,v retrieving revision 1.15 retrieving revision 1.16 diff -u -p -r1.15 -r1.16 --- device-gtk.c 2005/06/26 18:05:03 1.15 +++ device-gtk.c 2005/11/25 01:41:58 1.16 ＠＠ -75,11 +75,19 ＠＠ static const struct memory_description g { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("gtk-device", gtk_device, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + gtk_device_data_description_1, + Lisp_Gtk_Device); +#else /* not NEW_GC */ extern const struct sized_memory_description gtk_device_data_description; const struct sized_memory_description gtk_device_data_description = { sizeof (struct gtk_device), gtk_device_data_description_1 }; +#endif /* not NEW_GC */  /************************************************************************/ ＠＠ -108,7 +116,11 ＠＠ extern Lisp_Object __get_gtk_font_truena static void allocate_gtk_device_struct (struct device *d) { +#ifdef NEW_GC + d->device_data = alloc_lrecord_type (struct gtk_device, &lrecord_gtk_device); +#else /* not NEW_GC */ d->device_data = xnew_and_zero (struct gtk_device); +#endif /* not NEW_GC */ DEVICE_GTK_DATA (d)->x_keysym_map_hashtable = Qnil; } ＠＠ -350,7 +362,11 ＠＠ gtk_mark_device (struct device *d) static void free_gtk_device_struct (struct device *d) { +#ifdef NEW_GC + mc_free (d->device_data); +#else /* not NEW_GC */ xfree (d->device_data, void *); +#endif /* not NEW_GC */ } static void ＠＠ -681,6 +697,10 ＠＠ Get the style information for a Gtk devi void syms_of_device_gtk (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (gtk_device); +#endif /* NEW_GC */ + DEFSUBR (Fgtk_keysym_on_keyboard_p); DEFSUBR (Fgtk_display_visual_class); DEFSUBR (Fgtk_display_visual_depth); 1.60 +39 -0 XEmacs/xemacs/src/device-msw.c Index: device-msw.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device-msw.c,v retrieving revision 1.59 retrieving revision 1.60 diff -u -p -r1.59 -r1.60 --- device-msw.c 2005/10/25 11:16:22 1.59 +++ device-msw.c 2005/11/25 01:41:58 1.60 ＠＠ -73,11 +73,19 ＠＠ static const struct memory_description m { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("mswindows-device", mswindows_device, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + mswindows_device_data_description_1, + Lisp_Mswindows_Device); +#else /* not NEW_GC */ extern const struct sized_memory_description mswindows_device_data_description; const struct sized_memory_description mswindows_device_data_description = { sizeof (struct mswindows_device), mswindows_device_data_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description msprinter_device_data_description_1 [] = { { XD_LISP_OBJECT, offsetof (struct msprinter_device, name) }, ＠＠ -86,11 +94,19 ＠＠ static const struct memory_description m { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("msprinter-device", msprinter_device, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + msprinter_device_data_description_1, + Lisp_Msprinter_Device); +#else /* not NEW_GC */ extern const struct sized_memory_description msprinter_device_data_description; const struct sized_memory_description msprinter_device_data_description = { sizeof (struct msprinter_device), msprinter_device_data_description_1 }; +#endif /* not NEW_GC */ static Lisp_Object allocate_devmode (DEVMODEW *src_devmode, int do_copy, Lisp_Object src_name, struct device *d); ＠＠ -146,7 +162,12 ＠＠ mswindows_init_device (struct device *d, init_baud_rate (d); init_one_device (d); +#ifdef NEW_GC + d->device_data = alloc_lrecord_type (struct mswindows_device, + &lrecord_mswindows_device); +#else /* not NEW_GC */ d->device_data = xnew_and_zero (struct mswindows_device); +#endif /* not NEW_GC */ hdc = CreateCompatibleDC (NULL); assert (hdc != NULL); DEVICE_MSWINDOWS_HCDC (d) = hdc; ＠＠ -279,7 +300,11 ＠＠ mswindows_delete_device (struct device * #endif DeleteDC (DEVICE_MSWINDOWS_HCDC (d)); +#ifdef NEW_GC + mc_free (d->device_data); +#else /* not NEW_GC */ xfree (d->device_data, void *); +#endif /* not NEW_GC */ } void ＠＠ -495,7 +520,12 ＠＠ msprinter_init_device (struct device *d, LONG dm_size; Extbyte *printer_name; +#ifdef NEW_GC + d->device_data = alloc_lrecord_type (struct msprinter_device, + &lrecord_msprinter_device); +#else /* not NEW_GC */ d->device_data = xnew_and_zero (struct msprinter_device); +#endif /* not NEW_GC */ DEVICE_INFD (d) = DEVICE_OUTFD (d) = -1; DEVICE_MSPRINTER_DEVMODE (d) = Qnil; ＠＠ -546,7 +576,11 ＠＠ msprinter_delete_device (struct device * DEVICE_MSPRINTER_DEVMODE (d) = Qnil; } +#ifdef NEW_GC + mc_free (d->device_data); +#else /* not NEW_GC */ xfree (d->device_data, void *); +#endif /* not NEW_GC */ } } ＠＠ -1344,6 +1378,11 ＠＠ void syms_of_device_mswindows (void) { INIT_LRECORD_IMPLEMENTATION (devmode); + +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (mswindows_device); + INIT_LRECORD_IMPLEMENTATION (msprinter_device); +#endif /* NEW_GC */ DEFSUBR (Fmsprinter_get_settings); DEFSUBR (Fmsprinter_select_settings); 1.19 +24 -0 XEmacs/xemacs/src/device-tty.c Index: device-tty.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device-tty.c,v retrieving revision 1.18 retrieving revision 1.19 diff -u -p -r1.18 -r1.19 --- device-tty.c 2005/01/24 23:33:49 1.18 +++ device-tty.c 2005/11/25 01:41:59 1.19 ＠＠ -44,10 +44,26 ＠＠ Boston, MA 02111-1307, USA. */ Lisp_Object Qinit_pre_tty_win, Qinit_post_tty_win;  +#ifdef NEW_GC +static const struct memory_description tty_device_data_description_1 [] = { + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("tty-device", tty_device, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + tty_device_data_description_1, + Lisp_Tty_Device); +#endif /* NEW_GC */ + static void allocate_tty_device_struct (struct device *d) { +#ifdef NEW_GC + d->device_data = alloc_lrecord_type (struct tty_device, &lrecord_tty_device); +#else /* not NEW_GC */ d->device_data = xnew_and_zero (struct tty_device); +#endif /* not NEW_GC */ } static void ＠＠ -97,6 +113,7 ＠＠ tty_init_device (struct device *d, Lisp_ call0 (Qinit_pre_tty_win); } +#ifndef NEW_GC static void free_tty_device_struct (struct device *d) { ＠＠ -109,6 +126,7 ＠＠ tty_delete_device (struct device *d) { free_tty_device_struct (d); } +#endif /* not NEW_GC */ #ifdef SIGWINCH ＠＠ -189,6 +207,10 ＠＠ tty_device_system_metrics (struct device void syms_of_device_tty (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (tty_device); +#endif /* NEW_GC */ + DEFSYMBOL (Qinit_pre_tty_win); DEFSYMBOL (Qinit_post_tty_win); } ＠＠ -198,7 +220,9 ＠＠ console_type_create_device_tty (void) { /* device methods */ CONSOLE_HAS_METHOD (tty, init_device); +#ifndef NEW_GC CONSOLE_HAS_METHOD (tty, delete_device); +#endif /* not NEW_GC */ #ifdef SIGWINCH CONSOLE_HAS_METHOD (tty, asynch_device_change); #endif /* SIGWINCH */ 1.66 +20 -0 XEmacs/xemacs/src/device-x.c Index: device-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device-x.c,v retrieving revision 1.65 retrieving revision 1.66 diff -u -p -r1.65 -r1.66 --- device-x.c 2005/10/25 11:16:22 1.65 +++ device-x.c 2005/11/25 01:41:59 1.66 ＠＠ -109,11 +109,19 ＠＠ static const struct memory_description x { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("x-device", x_device, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + x_device_data_description_1, + Lisp_X_Device); +#else /* not NEW_GC */ extern const struct sized_memory_description x_device_data_description; const struct sized_memory_description x_device_data_description = { sizeof (struct x_device), x_device_data_description_1 }; +#endif /* not NEW_GC */ /* Functions to synchronize mirroring resources and specifiers */ int in_resource_setting; ＠＠ -202,7 +210,11 ＠＠ static struct device *device_being_initi static void allocate_x_device_struct (struct device *d) { +#ifdef NEW_GC + d->device_data = alloc_lrecord_type (struct x_device, &lrecord_x_device); +#else /* not NEW_GC */ d->device_data = xnew_and_zero (struct x_device); +#endif /* not NEW_GC */ } static void ＠＠ -885,7 +897,11 ＠＠ x_mark_device (struct device *d) static void free_x_device_struct (struct device *d) { +#ifdef NEW_GC + mc_free (d->device_data); +#else /* not NEW_GC */ xfree (d->device_data, void *); +#endif /* not NEW_GC */ } static void ＠＠ -2037,6 +2053,10 ＠＠ See also `x-get-font-path'. void syms_of_device_x (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (x_device); +#endif /* NEW_GC */ + DEFSUBR (Fx_debug_mode); DEFSUBR (Fx_get_resource); DEFSUBR (Fx_get_resource_prefix); 1.37 +15 -0 XEmacs/xemacs/src/device.c Index: device.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/device.c,v retrieving revision 1.36 retrieving revision 1.37 diff -u -p -r1.36 -r1.37 --- device.c 2005/10/25 11:16:22 1.36 +++ device.c 2005/11/25 01:41:59 1.37 ＠＠ -86,13 +86,27 ＠＠ Lisp_Object Vdevice_class_list;  +#ifndef NEW_GC extern const struct sized_memory_description gtk_device_data_description; extern const struct sized_memory_description mswindows_device_data_description; extern const struct sized_memory_description msprinter_device_data_description; extern const struct sized_memory_description x_device_data_description; +#endif /* not NEW_GC */ static const struct memory_description device_data_description_1 []= { +#ifdef NEW_GC #ifdef HAVE_GTK + { XD_LISP_OBJECT, gtk_console }, +#endif +#ifdef HAVE_MS_WINDOWS + { XD_LISP_OBJECT, mswindows_console }, + { XD_LISP_OBJECT, msprinter_console }, +#endif +#ifdef HAVE_X_WINDOWS + { XD_LISP_OBJECT, x_console }, +#endif +#else /* not NEW_GC */ +#ifdef HAVE_GTK { XD_BLOCK_PTR, gtk_console, 1, { &gtk_device_data_description} }, #endif #ifdef HAVE_MS_WINDOWS ＠＠ -102,6 +116,7 ＠＠ static const struct memory_description d #ifdef HAVE_X_WINDOWS { XD_BLOCK_PTR, x_console, 1, { &x_device_data_description} }, #endif +#endif /* not NEW_GC */ { XD_END } }; 1.32 +103 -13 XEmacs/xemacs/src/dumper.c Index: dumper.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/dumper.c,v retrieving revision 1.31 retrieving revision 1.32 diff -u -p -r1.31 -r1.32 --- dumper.c 2005/10/14 01:22:00 1.31 +++ dumper.c 2005/11/25 01:41:59 1.32 ＠＠ -686,6 +686,12 ＠＠ pdump_bump_depth (void) } static void pdump_register_object (Lisp_Object obj); +#ifdef NEW_GC +static void pdump_register_object_array (Lisp_Object data, + Bytecount size, + const struct memory_description *desc, + int count); +#endif /* NEW_GC */ static void pdump_register_block_contents (const void *data, Bytecount size, const struct memory_description * ＠＠ -781,6 +787,20 ＠＠ pdump_register_sub (const void *data, co } break; } +#ifdef NEW_GC + case XD_LISP_OBJECT_BLOCK_PTR: + { + EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, + data); + const struct sized_memory_description *sdesc = + lispdesc_indirect_description (data, desc1->data2.descr); + const Lisp_Object *pobj = (const Lisp_Object *) rdata; + if (pobj) + pdump_register_object_array + (*pobj, sdesc->size, sdesc->description, count); + break; + } +#endif /* NEW_GC */ case XD_BLOCK_PTR: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, ＠＠ -876,6 +896,47 ＠＠ pdump_register_object (Lisp_Object obj) } } +#ifdef NEW_GC +static void +pdump_register_object_array (Lisp_Object obj, + Bytecount size, + const struct memory_description *desc, + int count) +{ + struct lrecord_header *objh; + const struct lrecord_implementation *imp; + + if (!POINTER_TYPE_P (XTYPE (obj))) + return; + + objh = XRECORD_LHEADER (obj); + if (!objh) + return; + + if (pdump_get_block (objh)) + return; + + imp = LHEADER_IMPLEMENTATION (objh); + + if (imp->description + && RECORD_DUMPABLE (objh)) + { + pdump_bump_depth (); + backtrace[pdump_depth - 1].obj = objh; + pdump_add_block (pdump_object_table + objh->type, + objh, lispdesc_block_size_1 (objh, size, desc), count); + pdump_register_block_contents (objh, size, desc, count); + --pdump_depth; + } + else + { + pdump_alert_undump_object[objh->type]++; + stderr_out ("Undumpable object type : %s\n", imp->name); + pdump_backtrace (); + } +} +#endif /* NEW_GC */ + /* Register the referenced objects in the array of COUNT blocks located at DATA; each block is described by SIZE and DESC. "Block" here simply means any block of memory. ＠＠ -994,6 +1055,9 ＠＠ pdump_store_new_pointer_offsets (int cou * (int *) rdata = val; break; } +#ifdef NEW_GC + case XD_LISP_OBJECT_BLOCK_PTR: +#endif /* NEW_GC */ case XD_OPAQUE_DATA_PTR: case XD_ASCII_STRING: case XD_BLOCK_PTR: ＠＠ -1173,7 +1237,9 ＠＠ pdump_scan_lisp_objects_by_alignment (vo if (pdump_object_table[i].align == align) for (elt = pdump_object_table[i].first; elt; elt = elt->next) { +#ifndef NEW_GC assert (elt->count == 1); +#endif /* not NEW_GC */ f (elt, lrecord_implementations_table[i]->description); } } ＠＠ -1234,6 +1300,9 ＠＠ pdump_reloc_one_mc (void *data, const st case XD_LONG: case XD_INT_RESET: break; +#ifdef NEW_GC + case XD_LISP_OBJECT_BLOCK_PTR: +#endif /* NEW_GC */ case XD_OPAQUE_DATA_PTR: case XD_ASCII_STRING: case XD_BLOCK_PTR: ＠＠ -1252,7 +1321,7 ＠＠ pdump_reloc_one_mc (void *data, const st if (POINTER_TYPE_P (XTYPE (*pobj)) && ! EQ (*pobj, Qnull_pointer)) - *pobj = wrap_pointer_1 ((char *) pdump_get_mc_addr + *pobj = wrap_pointer_1 ((Rawbyte *) pdump_get_mc_addr (XPNTR (*pobj))); break; } ＠＠ -1268,7 +1337,7 ＠＠ pdump_reloc_one_mc (void *data, const st if (POINTER_TYPE_P (XTYPE (*pobj)) && ! EQ (*pobj, Qnull_pointer)) - *pobj = wrap_pointer_1 ((char *) pdump_get_mc_addr + *pobj = wrap_pointer_1 ((Rawbyte *) pdump_get_mc_addr (XPNTR (*pobj))); } break; ＠＠ -1687,7 +1756,16 ＠＠ pdump_dump_rtables (void) while (elt) { EMACS_INT rdata = pdump_get_block (elt->obj)->save_offset; +#ifdef NEW_GC + int j; + for (j=0; j<elt->count; j++) + { + PDUMP_WRITE_ALIGNED (EMACS_INT, rdata); + rdata += elt->size; + } +#else /* not NEW_GC */ PDUMP_WRITE_ALIGNED (EMACS_INT, rdata); +#endif /* not NEW_GC */ elt = elt->next; } } ＠＠ -2136,6 +2214,14 ＠＠ pdump_load_finish (void) EMACS_INT count; pdump_header *header = (pdump_header *) pdump_start; +#ifdef NEW_GC + /* This is a DEFVAR_BOOL and gets dumped, but the actual value was + already determined by vdb_install_signal_handler () in + vdb-mprotect.c, which could be different from the value in the + dump file. So store it here and restore it after loading the dump + file. */ + int allow_inc_gc = allow_incremental_gc; +#endif /* NEW_GC */ pdump_end = pdump_start + pdump_length; delta = ((EMACS_INT) pdump_start) - header->reloc_address; ＠＠ -2163,16 +2249,16 ＠＠ pdump_load_finish (void) Bytecount real_size = size * elt_count; if (count == 2) { - mc_addr = (Rawbyte *) mc_alloc (real_size); + if (elt_count <= 1) + mc_addr = (Rawbyte *) mc_alloc (real_size); +#ifdef NEW_GC + else + mc_addr = (Rawbyte *) mc_alloc_array (size, elt_count); +#endif /* NEW_GC */ #ifdef ALLOC_TYPE_STATS inc_lrecord_stats (real_size, (const struct lrecord_header *) - ((char *) rdata + delta)); - if (((const struct lrecord_header *) - ((char *) rdata + delta))->type - == lrecord_type_string) - inc_lrecord_string_data_stats - (((Lisp_String *) ((char *) rdata + delta))->size_); + ((Rawbyte *) rdata + delta)); #endif /* ALLOC_TYPE_STATS */ } else ＠＠ -2182,7 +2268,7 ＠＠ pdump_load_finish (void) mc_addr += size; pdump_put_mc_addr ((void *) rdata, (EMACS_INT) mc_addr); - memcpy (mc_addr, (char *) rdata + delta, size); + memcpy (mc_addr, (Rawbyte *) rdata + delta, size); } } else if (!(--count)) ＠＠ -2217,13 +2303,13 ＠＠ pdump_load_finish (void) p = (Rawbyte *) ALIGN_PTR (p, Rawbyte *); if (rt.desc) { - char **reloc = (char **) p; + Rawbyte **reloc = (Rawbyte **) p; for (i = 0; i < rt.count; i++) { - reloc[i] = (char *) pdump_get_mc_addr (reloc[i]); + reloc[i] = (Rawbyte *) pdump_get_mc_addr (reloc[i]); pdump_reloc_one_mc (reloc[i], rt.desc); } - p += rt.count * sizeof (char *); + p += rt.count * sizeof (Rawbyte *); } else if (!(--count)) break; ＠＠ -2319,6 +2405,10 ＠＠ pdump_load_finish (void) #ifdef MC_ALLOC xfree (pdump_mc_hash, mc_addr_elt *); #endif /* MC_ALLOC */ + +#ifdef NEW_GC + allow_incremental_gc = allow_inc_gc; +#endif /* NEW_GC */ return 1; } 1.13 +57 -0 XEmacs/xemacs/src/dynarr.c Index: dynarr.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/dynarr.c,v retrieving revision 1.12 retrieving revision 1.13 diff -u -p -r1.12 -r1.13 --- dynarr.c 2005/01/24 23:33:50 1.12 +++ dynarr.c 2005/11/25 01:41:59 1.13 ＠＠ -150,6 +150,39 ＠＠ Dynarr_newf (int elsize) return d; } +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("dynarr", dynarr, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + 0, + Dynarr); + +static void +Dynarr_lisp_realloc (Dynarr *dy, Elemcount new_size) +{ + void *new_base = alloc_lrecord_array (dy->elsize, new_size, dy->lisp_imp); + void *old_base = dy->base; + if (dy->base) + memcpy (new_base, dy->base, + (dy->max > new_size ? dy->max : new_size) * dy->elsize); + dy->base = new_base; + if (old_base) + mc_free (old_base); +} + +void * +Dynarr_lisp_newf (int elsize, + const struct lrecord_implementation *dynarr_imp, + const struct lrecord_implementation *imp) +{ + Dynarr *d = (Dynarr *) alloc_lrecord (sizeof (Dynarr), dynarr_imp); + d->elsize = elsize; + d->lisp_imp = imp; + + return d; +} +#endif /* not NEW_GC */ + void Dynarr_resize (void *d, Elemcount size) { ＠＠ -168,7 +201,14 ＠＠ Dynarr_resize (void *d, Elemcount size) /* Don't do anything if the array is already big enough. */ if (newsize > dy->max) { +#ifdef NEW_GC + if (dy->lisp_imp) + Dynarr_lisp_realloc (dy, newsize); + else + Dynarr_realloc (dy, newsize*dy->elsize); +#else /* not NEW_GC */ Dynarr_realloc (dy, newsize*dy->elsize); +#endif /* not NEW_GC */ dy->max = newsize; } } ＠＠ -222,10 +262,27 ＠＠ Dynarr_free (void *d) { Dynarr *dy = (Dynarr *) d; +#ifdef NEW_GC + if (dy->base && !DUMPEDP (dy->base)) + { + if (dy->lisp_imp) + mc_free (dy->base); + else + xfree (dy->base, void *); + } + if(!DUMPEDP (dy)) + { + if (dy->lisp_imp) + mc_free (dy); + else + xfree (dy, Dynarr *); + } +#else /* not NEW_GC */ if (dy->base && !DUMPEDP (dy->base)) xfree (dy->base, void *); if(!DUMPEDP (dy)) xfree (dy, Dynarr *); +#endif /* not NEW_GC */ } #ifdef MEMORY_USAGE_STATS 1.44 +75 -1 XEmacs/xemacs/src/elhash.c Index: elhash.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/elhash.c,v retrieving revision 1.43 retrieving revision 1.44 diff -u -p -r1.43 -r1.44 --- elhash.c 2005/10/24 10:07:35 1.43 +++ elhash.c 2005/11/25 01:42:00 1.44 ＠＠ -96,6 +96,9 ＠＠ static Lisp_Object Qnon_weak, Q_type; typedef struct htentry { +#ifdef NEW_GC + struct lrecord_header lheader; +#endif /* NEW_GC */ Lisp_Object key; Lisp_Object value; } htentry; ＠＠ -406,7 +409,12 ＠＠ print_hash_table (Lisp_Object obj, Lisp_ } static void -free_hentries (htentry *hentries, +free_hentries ( +#if defined (NEW_GC) && !defined (ERROR_CHECK_STRUCTURES) + htentry *UNUSED (hentries), +#else + htentry *hentries, +#endif #ifdef ERROR_CHECK_STRUCTURES size_t size #else ＠＠ -414,6 +422,14 ＠＠ free_hentries (htentry *hentries, #endif ) { +#ifdef NEW_GC +#ifdef ERROR_CHECK_STRUCTURES + htentry *e, *sentinel; + + for (e = hentries, sentinel = e + size; e < sentinel; e++) + mc_free (e); +#endif +#else /* not NEW_GC */ #ifdef ERROR_CHECK_STRUCTURES /* Ensure a crash if other code uses the discarded entries afterwards. */ htentry *e, *sentinel; ＠＠ -424,6 +440,7 ＠＠ free_hentries (htentry *hentries, if (!DUMPEDP (hentries)) xfree (hentries, htentry *); +#endif /* not NEW_GC */ } static void ＠＠ -448,13 +465,39 ＠＠ static const struct sized_memory_descrip htentry_description_1 }; +#ifdef NEW_GC +static const struct memory_description htentry_weak_description_1[] = { + { XD_LISP_OBJECT, offsetof (htentry, key), 0, { 0 }, XD_FLAG_NO_KKCC}, + { XD_LISP_OBJECT, offsetof (htentry, value), 0, { 0 }, XD_FLAG_NO_KKCC}, + { XD_END } +}; + +static const struct sized_memory_description htentry_weak_description = { + sizeof (htentry), + htentry_weak_description_1 +}; + +DEFINE_LRECORD_IMPLEMENTATION ("hash-table-entry", hash_table_entry, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + htentry_description_1, + Lisp_Hash_Table_Entry); +#endif /* NEW_GC */ + static const struct memory_description htentry_union_description_1[] = { /* Note: XD_INDIRECT in this table refers to the surrounding table, and so this will work. */ +#ifdef NEW_GC + { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, + XD_INDIRECT (0, 1), { &htentry_description } }, + { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), + { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), { &htentry_description } }, { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_description }, XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC }, +#endif /* not NEW_GC */ { XD_END } }; ＠＠ -572,7 +615,13 ＠＠ make_general_lisp_hash_table (hash_table compute_hash_table_derived_values (ht); /* We leave room for one never-occupied sentinel htentry at the end. */ +#ifdef NEW_GC + ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), + ht->size + 1, + &lrecord_hash_table_entry); +#else /* not NEW_GC */ ht->hentries = xnew_array_and_zero (htentry, ht->size + 1); +#endif /* not NEW_GC */ hash_table = wrap_hash_table (ht); ＠＠ -970,7 +1019,13 ＠＠ The keys and values will not themselves Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); COPY_LCRECORD (ht, ht_old); +#ifdef NEW_GC + ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), + ht_old->size + 1, + &lrecord_hash_table_entry); +#else /* not NEW_GC */ ht->hentries = xnew_array (htentry, ht_old->size + 1); +#endif /* not NEW_GC */ memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry)); hash_table = wrap_hash_table (ht); ＠＠ -995,7 +1050,13 ＠＠ resize_hash_table (Lisp_Hash_Table *ht, old_entries = ht->hentries; +#ifdef NEW_GC + ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), + new_size + 1, + &lrecord_hash_table_entry); +#else /* not NEW_GC */ ht->hentries = xnew_array_and_zero (htentry, new_size + 1); +#endif /* not NEW_GC */ new_entries = ht->hentries; compute_hash_table_derived_values (ht); ＠＠ -1019,7 +1080,13 ＠＠ void pdump_reorganize_hash_table (Lisp_Object hash_table) { const Lisp_Hash_Table *ht = xhash_table (hash_table); +#ifdef NEW_GC + htentry *new_entries = + (htentry *) alloc_lrecord_array (sizeof (htentry), ht->size + 1, + &lrecord_hash_table_entry); +#else /* not NEW_GC */ htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1); +#endif /* not NEW_GC */ htentry *e, *sentinel; for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) ＠＠ -1033,7 +1100,11 ＠＠ pdump_reorganize_hash_table (Lisp_Object memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry)); +#ifdef NEW_GC + mc_free (new_entries); +#else /* not NEW_GC */ xfree (new_entries, htentry *); +#endif /* not NEW_GC */ } static void ＠＠ -1761,6 +1832,9 ＠＠ void init_elhash_once_early (void) { INIT_LRECORD_IMPLEMENTATION (hash_table); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (hash_table_entry); +#endif /* NEW_GC */ /* This must NOT be staticpro'd */ Vall_weak_hash_tables = Qnil; 1.16 +13 -0 XEmacs/xemacs/src/elhash.h Index: elhash.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/elhash.h,v retrieving revision 1.15 retrieving revision 1.16 diff -u -p -r1.15 -r1.16 --- elhash.h 2005/01/26 10:22:25 1.15 +++ elhash.h 2005/11/25 01:42:00 1.16 ＠＠ -33,6 +33,19 ＠＠ DECLARE_LRECORD (hash_table, Lisp_Hash_T #define CHECK_HASH_TABLE(x) CHECK_RECORD (x, hash_table) #define CONCHECK_HASH_TABLE(x) CONCHECK_RECORD (x, hash_table) +#ifdef NEW_GC +typedef struct htentry Lisp_Hash_Table_Entry; + +DECLARE_LRECORD (hash_table_entry, Lisp_Hash_Table_Entry); + +#define XHASH_TABLE_ENTRY(x) \ + XRECORD (x, hash_table_entry, Lisp_Hash_Table_Entry) +#define wrap_hash_table_entry(p) wrap_record (p, hash_table_entry) +#define HASH_TABLE_ENTRYP(x) RECORDP (x, hash_table_entry) +#define CHECK_HASH_TABLE_ENTRY(x) CHECK_RECORD (x, hash_table_entry) +#define CONCHECK_HASH_TABLE_ENTRY(x) CONCHECK_RECORD (x, hash_table_entry) +#endif /* NEW_GC */ + enum hash_table_weakness { HASH_TABLE_NON_WEAK, 1.161 +43 -3 XEmacs/xemacs/src/emacs.c Index: emacs.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/emacs.c,v retrieving revision 1.160 retrieving revision 1.161 diff -u -p -r1.160 -r1.161 --- emacs.c 2005/10/25 08:32:47 1.160 +++ emacs.c 2005/11/25 01:42:00 1.161 ＠＠ -1312,6 +1312,9 ＠＠ main_1 (int argc, Wexttext **argv, Wextt the Lisp engine and need to be done both at dump time and at run time. */ init_signals_very_early (); +#ifdef NEW_GC + vdb_install_signal_handler (); +#endif init_data_very_early (); /* Catch math errors. */ init_floatfns_very_early (); /* Catch floating-point math errors. */ init_process_times_very_early (); /* Initialize our process timers. ＠＠ -1397,6 +1400,8 ＠＠ main_1 (int argc, Wexttext **argv, Wextt init_alloc_early (); + init_gc_early (); + if (!initialized) { /* Initialize things so that new Lisp objects ＠＠ -1406,6 +1411,8 ＠＠ main_1 (int argc, Wexttext **argv, Wextt routines below create new objects. */ init_alloc_once_early (); + init_gc_once_early (); + /* Initialize Qnil, Qt, Qunbound, and the obarray. After this, symbols can be interned. This depends on init_alloc_once_early(). */ ＠＠ -1444,6 +1451,10 ＠＠ main_1 (int argc, Wexttext **argv, Wextt #ifdef MC_ALLOC syms_of_mc_alloc (); #endif /* MC_ALLOC */ + syms_of_gc (); +#ifdef NEW_GC + syms_of_vdb (); +#endif /* NEW_GC */ syms_of_buffer (); syms_of_bytecode (); syms_of_callint (); ＠＠ -1850,6 +1861,7 ＠＠ main_1 (int argc, Wexttext **argv, Wextt (note, we are inside ifdef PDUMP) */ { reinit_alloc_early (); + reinit_gc_early (); reinit_symbols_early (); #ifndef MC_ALLOC reinit_opaque_early (); ＠＠ -2054,6 +2066,7 ＠＠ main_1 (int argc, Wexttext **argv, Wextt vars_of_font_lock (); #endif /* USE_C_FONT_LOCK */ vars_of_frame (); + vars_of_gc (); vars_of_glyphs (); vars_of_glyphs_eimage (); vars_of_glyphs_widget (); ＠＠ -2394,9 +2407,6 ＠＠ main_1 (int argc, Wexttext **argv, Wextt #endif /* This calls Fmake_glyph_internal(). */ - complex_vars_of_alloc (); - - /* This calls Fmake_glyph_internal(). */ #ifdef HAVE_MENUBARS complex_vars_of_menubar (); #endif ＠＠ -2439,6 +2449,8 ＠＠ main_1 (int argc, Wexttext **argv, Wextt might depend on all sorts of things; I'm not sure. */ complex_vars_of_emacs (); + complex_vars_of_gc (); + /* This creates a couple of basic keymaps and depends on Lisp hash tables and Ffset() (both of which depend on some variables initialized in the vars_of_*() section) and possibly other ＠＠ -2449,7 +2461,11 ＠＠ main_1 (int argc, Wexttext **argv, Wextt { extern int always_gc; if (always_gc) /* purification debugging hack */ +#ifdef NEW_GC + gc_full (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ } #endif } ＠＠ -2928,7 +2944,11 ＠＠ Do not call this. It will reinitialize { int i; +#ifdef NEW_GC + if (gc_in_progress) gc_full (); +#else /* not NEW_GC */ assert (!gc_in_progress); +#endif /* not NEW_GC */ if (run_temacs_argc < 0) invalid_operation ("I've lost my temacs-hood", Qunbound); ＠＠ -3204,7 +3224,11 ＠＠ and announce itself normally when it is memory_warnings (my_edata, malloc_warning); #endif +#ifdef NEW_GC + gc_full (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ #ifdef PDUMP pdump (); ＠＠ -3728,12 +3752,28 ＠＠ fatal_error_signal (int sig) guts_of_fatal_error_signal (sig); +#ifdef NEW_GC + /* This time the signal will really be fatal. To be able to debug + SIGSEGV and SIGBUS also during write barrier, send SIGABRT. */ +#ifdef WIN32_NATIVE + if (sig == SIGSEGV) + raise (SIGABRT); + else + raise (sig); +#else + if ((sig == SIGSEGV) || (sig == SIGBUS)) + kill (qxe_getpid (), SIGABRT); + else + kill (qxe_getpid (), sig); +#endif +#else /* not NEW_GC */ /* Signal the same code; this time it will really be fatal. */ #ifdef WIN32_NATIVE raise (sig); #else kill (qxe_getpid (), sig); #endif +#endif /* not NEW_GC */ SIGRETURN; } 1.91 +45 -0 XEmacs/xemacs/src/eval.c Index: eval.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/eval.c,v retrieving revision 1.90 retrieving revision 1.91 diff -u -p -r1.90 -r1.91 --- eval.c 2005/10/25 11:16:23 1.90 +++ eval.c 2005/11/25 01:42:00 1.91 ＠＠ -2238,7 +2238,9 ＠＠ user invokes the "return from signal" op ABORT (); } +#ifndef NEW_GC assert (!gc_in_progress); +#endif /* not NEW_GC */ /* We abort if in_display and we are not protected, as garbage collections and non-local exits will invariably be fatal, but in ＠＠ -3371,14 +3373,32 ＠＠ handle_compiled_function_with_and_rest ( int bindargs = min (nargs, max_non_rest_args); for (i = 0; i < bindargs; i++) +#ifdef NEW_GC + SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], + args[i]); +#else /* not NEW_GC */ SPECBIND_FAST_UNSAFE (f->args[i], args[i]); +#endif /* not NEW_GC */ for (i = bindargs; i < max_non_rest_args; i++) +#ifdef NEW_GC + SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], + Qnil); +#else /* not NEW_GC */ SPECBIND_FAST_UNSAFE (f->args[i], Qnil); +#endif /* not NEW_GC */ +#ifdef NEW_GC SPECBIND_FAST_UNSAFE + (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args], + nargs > max_non_rest_args ? + Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : + Qnil); +#else /* not NEW_GC */ + SPECBIND_FAST_UNSAFE (f->args[max_non_rest_args], nargs > max_non_rest_args ? Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) : Qnil); +#endif /* not NEW_GC */ } /* Apply compiled-function object FUN to the NARGS evaluated arguments ＠＠ -3405,7 +3425,12 ＠＠ funcall_compiled_function (Lisp_Object f { #if 1 for (i = 0; i < nargs; i++) +#ifdef NEW_GC + SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], + args[i]); +#else /* not NEW_GC */ SPECBIND_FAST_UNSAFE (f->args[i], args[i]); +#endif /* not NEW_GC */ #else /* Here's an alternate way to write the loop that tries to further optimize funcalls for functions with few arguments by partially ＠＠ -3436,9 +3461,19 ＠＠ funcall_compiled_function (Lisp_Object f else if (nargs < f->max_args) { for (i = 0; i < nargs; i++) +#ifdef NEW_GC + SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], + args[i]); +#else /* not NEW_GC */ SPECBIND_FAST_UNSAFE (f->args[i], args[i]); +#endif /* not NEW_GC */ for (i = nargs; i < f->max_args; i++) +#ifdef NEW_GC + SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i], + Qnil); +#else /* not NEW_GC */ SPECBIND_FAST_UNSAFE (f->args[i], Qnil); +#endif /* not NEW_GC */ } else if (f->max_args == MANY) handle_compiled_function_with_and_rest (f, nargs, args); ＠＠ -3527,7 +3562,11 ＠＠ Evaluate FORM and return its value. { struct gcpro gcpro1; GCPRO1 (form); +#ifdef NEW_GC + gc_incremental (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ UNGCPRO; } ＠＠ -3779,7 +3818,11 ＠＠ Thus, (funcall 'cons 'x 'y) returns (x . { if (need_to_garbage_collect) /* Callers should gcpro lexpr args */ +#ifdef NEW_GC + gc_incremental (); +#else /* not NEW_GC */ garbage_collect_1 (); +#endif /* not NEW_GC */ if (need_to_check_c_alloca) { if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP) ＠＠ -4305,9 +4348,11 ＠＠ run_hook_with_args_in_buffer (struct buf /* We need to bail out of here pronto. */ return Qnil; +#ifndef NEW_GC /* Whenever gc_in_progress is true, preparing_for_armageddon will also be true unless something is really hosed. */ assert (!gc_in_progress); +#endif /* not NEW_GC */ sym = args[0]; val = symbol_value_in_buffer (sym, wrap_buffer (buf)); 1.106 +2 -0 XEmacs/xemacs/src/event-msw.c Index: event-msw.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/event-msw.c,v retrieving revision 1.105 retrieving revision 1.106 diff -u -p -r1.105 -r1.106 --- event-msw.c 2005/10/25 11:16:23 1.105 +++ event-msw.c 2005/11/25 01:42:01 1.106 ＠＠ -2498,9 +2498,11 ＠＠ mswindows_wnd_proc (HWND hwnd, UINT mess struct frame *frame; struct mswindows_frame *msframe; +#ifndef NEW_GC /* If you hit this, rewrite the offending API call to occur after GC, using register_post_gc_action(). */ assert (!gc_in_progress); +#endif /* NEW_GC */ #ifdef DEBUG_XEMACS if (debug_mswindows_events) 1.71 +3 -0 XEmacs/xemacs/src/events.c Index: events.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/events.c,v retrieving revision 1.70 retrieving revision 1.71 diff -u -p -r1.70 -r1.71 --- events.c 2005/11/13 10:48:03 1.70 +++ events.c 2005/11/25 01:42:01 1.71 ＠＠ -2650,6 +2650,9 ＠＠ void reinit_vars_of_events (void) { Vevent_resource = Qnil; +#ifdef NEW_GC + staticpro (&Vevent_resource); +#endif /* NEW_GC */ } void 1.63 +160 -0 XEmacs/xemacs/src/extents.c Index: extents.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/extents.c,v retrieving revision 1.62 retrieving revision 1.63 diff -u -p -r1.62 -r1.63 --- extents.c 2005/10/25 11:16:23 1.62 +++ extents.c 2005/11/25 01:42:01 1.63 ＠＠ -242,6 +242,9 ＠＠ Boston, MA 02111-1307, USA. */ typedef struct gap_array_marker { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ int pos; struct gap_array_marker *next; } Gap_Array_Marker; ＠＠ -269,6 +272,9 ＠＠ typedef struct gap_array_marker typedef struct gap_array { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Elemcount gap; Elemcount gapsize; Elemcount numels; ＠＠ -281,7 +287,9 ＠＠ typedef struct gap_array char array[1]; } Gap_Array; +#ifndef NEW_GC static Gap_Array_Marker *gap_array_marker_freelist; +#endif /* not NEW_GC */ /* Convert a "memory position" (i.e. taking the gap into account) into the address of the element at (i.e. after) that position. "Memory ＠＠ -310,6 +318,9 ＠＠ static Gap_Array_Marker *gap_array_marke typedef struct extent_list_marker { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Gap_Array_Marker *m; int endp; struct extent_list_marker *next; ＠＠ -317,12 +328,17 ＠＠ typedef struct extent_list_marker typedef struct extent_list { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Gap_Array *start; Gap_Array *end; Extent_List_Marker *markers; } Extent_List; +#ifndef NEW_GC static Extent_List_Marker *extent_list_marker_freelist; +#endif /* not NEW_GC */ #define EXTENT_LESS_VALS(e,st,nd) ((extent_start (e) < (st)) || \ ((extent_start (e) == (st)) && \ ＠＠ -377,6 +393,9 ＠＠ struct extent_auxiliary extent_auxiliary typedef struct stack_of_extents { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Extent_List *extents; Memxpos pos; /* Position of stack of extents. EXTENTS is the list of all extents that overlap this position. This position ＠＠ -569,10 +588,17 ＠＠ gap_array_make_gap (Gap_Array *ga, Elemc a geometric progression that saves on realloc space. */ increment += 100 + ga->numels / 8; +#ifdef NEW_GC + ga = (Gap_Array *) mc_realloc (ga, + offsetof (Gap_Array, array) + + (ga->numels + ga->gapsize + increment) * + ga->elsize); +#else /* not NEW_GC */ ga = (Gap_Array *) xrealloc (ga, offsetof (Gap_Array, array) + (ga->numels + ga->gapsize + increment) * ga->elsize); +#endif /* not NEW_GC */ if (ga == 0) memory_full (); ＠＠ -664,6 +690,9 ＠＠ gap_array_make_marker (Gap_Array *ga, El Gap_Array_Marker *m; assert (pos >= 0 && pos <= ga->numels); +#ifdef NEW_GC + m = alloc_lrecord_type (Gap_Array_Marker, &lrecord_gap_array_marker); +#else /* not NEW_GC */ if (gap_array_marker_freelist) { m = gap_array_marker_freelist; ＠＠ -671,6 +700,7 ＠＠ gap_array_make_marker (Gap_Array *ga, El } else m = xnew (Gap_Array_Marker); +#endif /* not NEW_GC */ m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); m->next = ga->markers; ＠＠ -690,11 +720,16 ＠＠ gap_array_delete_marker (Gap_Array *ga, prev->next = p->next; else ga->markers = p->next; +#ifdef NEW_GC + mc_free (m); +#else /* not NEW_GC */ m->next = gap_array_marker_freelist; m->pos = 0xDEADBEEF; /* -559038737 base 10 */ gap_array_marker_freelist = m; +#endif /* not NEW_GC */ } +#ifndef NEW_GC static void gap_array_delete_all_markers (Gap_Array *ga) { ＠＠ -708,6 +743,7 ＠＠ gap_array_delete_all_markers (Gap_Array gap_array_marker_freelist = p; } } +#endif /* not NEW_GC */ static void gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, Elemcount pos) ＠＠ -722,17 +758,23 ＠＠ gap_array_move_marker (Gap_Array *ga, Ga static Gap_Array * make_gap_array (Elemcount elsize) { +#ifdef NEW_GC + Gap_Array *ga = alloc_lrecord_type (Gap_Array, &lrecord_gap_array); +#else /* not NEW_GC */ Gap_Array *ga = xnew_and_zero (Gap_Array); +#endif /* not NEW_GC */ ga->elsize = elsize; return ga; } +#ifndef NEW_GC static void free_gap_array (Gap_Array *ga) { gap_array_delete_all_markers (ga); xfree (ga, Gap_Array *); } +#endif /* not NEW_GC */  /************************************************************************/ ＠＠ -887,6 +929,9 ＠＠ extent_list_make_marker (Extent_List *el { Extent_List_Marker *m; +#ifdef NEW_GC + m = alloc_lrecord_type (Extent_List_Marker, &lrecord_extent_list_marker); +#else /* not NEW_GC */ if (extent_list_marker_freelist) { m = extent_list_marker_freelist; ＠＠ -894,6 +939,7 ＠＠ extent_list_make_marker (Extent_List *el } else m = xnew (Extent_List_Marker); +#endif /* not NEW_GC */ m->m = gap_array_make_marker (endp ? el->end : el->start, pos); m->endp = endp; ＠＠ -917,9 +963,13 ＠＠ extent_list_delete_marker (Extent_List * prev->next = p->next; else el->markers = p->next; +#ifdef NEW_GC + gap_array_delete_marker (m->endp ? el->end : el->start, m->m); +#else /* not NEW_GC */ m->next = extent_list_marker_freelist; extent_list_marker_freelist = m; gap_array_delete_marker (m->endp ? el->end : el->start, m->m); +#endif /* not NEW_GC */ } #define extent_list_marker_pos(el, mkr) \ ＠＠ -928,13 +978,18 ＠＠ extent_list_delete_marker (Extent_List * static Extent_List * allocate_extent_list (void) { +#ifdef NEW_GC + Extent_List *el = alloc_lrecord_type (Extent_List, &lrecord_extent_list); +#else /* not NEW_GC */ Extent_List *el = xnew (Extent_List); +#endif /* not NEW_GC */ el->start = make_gap_array (sizeof (EXTENT)); el->end = make_gap_array (sizeof (EXTENT)); el->markers = 0; return el; } +#ifndef NEW_GC static void free_extent_list (Extent_List *el) { ＠＠ -942,6 +997,7 ＠＠ free_extent_list (Extent_List *el) free_gap_array (el->end); xfree (el, Extent_List *); } +#endif /* not NEW_GC */  /************************************************************************/ ＠＠ -1021,28 +1077,46 ＠＠ allocate_extent_auxiliary (EXTENT ext) structure to be there. */ static struct stack_of_extents *allocate_soe (void); +#ifndef NEW_GC static void free_soe (struct stack_of_extents *soe); +#endif /* not NEW_GC */ static void soe_invalidate (Lisp_Object obj); extern const struct sized_memory_description gap_array_marker_description; static const struct memory_description gap_array_marker_description_1[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Gap_Array_Marker, next) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Gap_Array_Marker, next), 1, { &gap_array_marker_description } }, +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("gap-array-marker", gap_array_marker, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + gap_array_marker_description_1, + struct gap_array_marker); +#else /* not NEW_GC */ const struct sized_memory_description gap_array_marker_description = { sizeof (Gap_Array_Marker), gap_array_marker_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description lispobj_gap_array_description_1[] = { { XD_ELEMCOUNT, offsetof (Gap_Array, gap) }, { XD_BYTECOUNT, offsetof (Gap_Array, offset_past_gap) }, { XD_ELEMCOUNT, offsetof (Gap_Array, els_past_gap) }, +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Gap_Array, markers) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Gap_Array, markers), 1, { &gap_array_marker_description }, XD_FLAG_NO_KKCC }, +#endif /* not NEW_GC */ { XD_BLOCK_ARRAY, offsetof (Gap_Array, array), XD_INDIRECT (0, 0), { &lisp_object_description } }, { XD_BLOCK_ARRAY, XD_INDIRECT (1, offsetof (Gap_Array, array)), ＠＠ -1050,57 +1124,118 ＠＠ static const struct memory_description l { XD_END } }; +#ifdef NEW_GC + +static Bytecount +size_gap_array (const void *lheader) +{ + Gap_Array *ga = (Gap_Array *) lheader; + return offsetof (Gap_Array, array) + (ga->numels + ga->gapsize) * ga->elsize; +} + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("gap-array", gap_array, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + lispobj_gap_array_description_1, + size_gap_array, + struct gap_array); +#else /* not NEW_GC */ static const struct sized_memory_description lispobj_gap_array_description = { sizeof (Gap_Array), lispobj_gap_array_description_1 }; extern const struct sized_memory_description extent_list_marker_description; +#endif /* not NEW_GC */ static const struct memory_description extent_list_marker_description_1[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Extent_List_Marker, m) }, + { XD_LISP_OBJECT, offsetof (Extent_List_Marker, next) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Extent_List_Marker, m), 1, { &gap_array_marker_description } }, { XD_BLOCK_PTR, offsetof (Extent_List_Marker, next), 1, { &extent_list_marker_description } }, +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("extent-list-marker", extent_list_marker, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + extent_list_marker_description_1, + struct extent_list_marker); +#else /* not NEW_GC */ const struct sized_memory_description extent_list_marker_description = { sizeof (Extent_List_Marker), extent_list_marker_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description extent_list_description_1[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Extent_List, start) }, + { XD_LISP_OBJECT, offsetof (Extent_List, end) }, + { XD_LISP_OBJECT, offsetof (Extent_List, markers) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Extent_List, start), 1, { &lispobj_gap_array_description } }, { XD_BLOCK_PTR, offsetof (Extent_List, end), 1, { &lispobj_gap_array_description }, XD_FLAG_NO_KKCC }, { XD_BLOCK_PTR, offsetof (Extent_List, markers), 1, { &extent_list_marker_description }, XD_FLAG_NO_KKCC }, +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("extent-list", extent_list, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + extent_list_description_1, + struct extent_list); +#else /* not NEW_GC */ static const struct sized_memory_description extent_list_description = { sizeof (Extent_List), extent_list_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description stack_of_extents_description_1[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Stack_Of_Extents, extents) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Stack_Of_Extents, extents), 1, { &extent_list_description } }, +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("stack-of-extents", stack_of_extents, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + stack_of_extents_description_1, + struct stack_of_extents); +#else /* not NEW_GC */ static const struct sized_memory_description stack_of_extents_description = { sizeof (Stack_Of_Extents), stack_of_extents_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description extent_info_description [] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (struct extent_info, extents) }, + { XD_LISP_OBJECT, offsetof (struct extent_info, soe) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (struct extent_info, extents), 1, { &extent_list_description } }, { XD_BLOCK_PTR, offsetof (struct extent_info, soe), 1, { &stack_of_extents_description }, XD_FLAG_NO_KKCC }, +#endif /* not NEW_GC */ { XD_END } }; ＠＠ -1142,6 +1277,10 ＠＠ finalize_extent_info (void *header, int if (for_disksave) return; +#ifdef NEW_GC + data->soe = 0; + data->extents = 0; +#else /* not NEW_GC */ if (data->soe) { free_soe (data->soe); ＠＠ -1152,6 +1291,7 ＠＠ finalize_extent_info (void *header, int free_extent_list (data->extents); data->extents = 0; } +#endif /* not NEW_GC */ } DEFINE_LRECORD_IMPLEMENTATION ("extent-info", extent_info, ＠＠ -1181,7 +1321,9 ＠＠ flush_cached_extent_info (Lisp_Object ex if (data->soe) { +#ifndef NEW_GC free_soe (data->soe); +#endif /* not NEW_GC */ data->soe = 0; } } ＠＠ -1326,12 +1468,16 ＠＠ init_buffer_extents (struct buffer *b) void uninit_buffer_extents (struct buffer *b) { +#ifndef NEW_GC struct extent_info *data = XEXTENT_INFO (b->extent_info); +#endif /* not NEW_GC */ /* Don't destroy the extents here -- there may still be children extents pointing to the extents. */ detach_all_extents (wrap_buffer (b)); +#ifndef NEW_GC finalize_extent_info (data, 0); +#endif /* not NEW_GC */ } /* Retrieve the extent list that an extent is a member of; the ＠＠ -1649,18 +1795,25 ＠＠ soe_invalidate (Lisp_Object obj) static struct stack_of_extents * allocate_soe (void) { +#ifdef NEW_GC + struct stack_of_extents *soe = + alloc_lrecord_type (struct stack_of_extents, &lrecord_stack_of_extents); +#else /* not NEW_GC */ struct stack_of_extents *soe = xnew_and_zero (struct stack_of_extents); +#endif /* not NEW_GC */ soe->extents = allocate_extent_list (); soe->pos = -1; return soe; } +#ifndef NEW_GC static void free_soe (struct stack_of_extents *soe) { free_extent_list (soe->extents); xfree (soe, struct stack_of_extents *); } +#endif /* not NEW_GC */ /* ------------------------------- */ /* other primitives */ ＠＠ -7299,6 +7452,13 ＠＠ syms_of_extents (void) INIT_LRECORD_IMPLEMENTATION (extent); INIT_LRECORD_IMPLEMENTATION (extent_info); INIT_LRECORD_IMPLEMENTATION (extent_auxiliary); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (gap_array_marker); + INIT_LRECORD_IMPLEMENTATION (gap_array); + INIT_LRECORD_IMPLEMENTATION (extent_list_marker); + INIT_LRECORD_IMPLEMENTATION (extent_list); + INIT_LRECORD_IMPLEMENTATION (stack_of_extents); +#endif /* not NEW_GC */ DEFSYMBOL (Qextentp); DEFSYMBOL (Qextent_live_p); 1.20 +50 -0 XEmacs/xemacs/src/extents.h Index: extents.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/extents.h,v retrieving revision 1.19 retrieving revision 1.20 diff -u -p -r1.19 -r1.20 --- extents.h 2005/01/26 05:11:12 1.19 +++ extents.h 2005/11/25 01:42:02 1.20 ＠＠ -49,6 +49,56 ＠＠ DECLARE_LRECORD (extent_info, struct ext #define CHECK_EXTENT_INFO(x) CHECK_RECORD (x, extent_info) #define CONCHECK_EXTENT_INFO(x) CONCHECK_RECORD (x, extent_info) +#ifdef NEW_GC +struct gap_array_marker; + +DECLARE_LRECORD (gap_array_marker, struct gap_array_marker); +#define XGAP_ARRAY_MARKER(x) \ + XRECORD (x, gap_array_marker, struct gap_array_marker) +#define wrap_gap_array_marker(p) wrap_record (p, gap_array_marker) +#define GAP_ARRAY_MARKERP(x) RECORDP (x, gap_array_marker) +#define CHECK_GAP_ARRAY_MARKER(x) CHECK_RECORD (x, gap_array_marker) +#define CONCHECK_GAP_ARRAY_MARKER(x) CONCHECK_RECORD (x, gap_array_marker) + +struct gap_array; + +DECLARE_LRECORD (gap_array, struct gap_array); +#define XGAP_ARRAY(x) XRECORD (x, gap_array, struct gap_array) +#define wrap_gap_array(p) wrap_record (p, gap_array) +#define GAP_ARRAYP(x) RECORDP (x, gap_array) +#define CHECK_GAP_ARRAY(x) CHECK_RECORD (x, gap_array) +#define CONCHECK_GAP_ARRAY(x) CONCHECK_RECORD (x, gap_array) + +struct extent_list_marker; + +DECLARE_LRECORD (extent_list_marker, struct extent_list_marker); +#define XEXTENT_LIST_MARKER(x) \ + XRECORD (x, extent_list_marker, struct extent_list_marker) +#define wrap_extent_list_marker(p) wrap_record (p, extent_list_marker) +#define EXTENT_LIST_MARKERP(x) RECORDP (x, extent_list_marker) +#define CHECK_EXTENT_LIST_MARKER(x) CHECK_RECORD (x, extent_list_marker) +#define CONCHECK_EXTENT_LIST_MARKER(x) CONCHECK_RECORD (x, extent_list_marker) + +struct extent_list; + +DECLARE_LRECORD (extent_list, struct extent_list); +#define XEXTENT_LIST(x) XRECORD (x, extent_list, struct extent_list) +#define wrap_extent_list(p) wrap_record (p, extent_list) +#define EXTENT_LISTP(x) RECORDP (x, extent_list) +#define CHECK_EXTENT_LIST(x) CHECK_RECORD (x, extent_list) +#define CONCHECK_EXTENT_LIST(x) CONCHECK_RECORD (x, extent_list) + +struct stack_of_extents; + +DECLARE_LRECORD (stack_of_extents, struct stack_of_extents); +#define XSTACK_OF_EXTENTS(x) \ + XRECORD (x, stack_of_extents, struct stack_of_extents) +#define wrap_stack_of_extents(p) wrap_record (p, stack_of_extents) +#define STACK_OF_EXTENTSP(x) RECORDP (x, stack_of_extents) +#define CHECK_STACK_OF_EXTENTS(x) CHECK_RECORD (x, stack_of_extents) +#define CONCHECK_STACK_OF_EXTENTS(x) CONCHECK_RECORD (x, stack_of_extents) +#endif /* NEW_GC */ + /* the layouts for glyphs (extent->flags.glyph_layout). Must fit in 2 bits. */ typedef enum glyph_layout { 1.15 +16 -0 XEmacs/xemacs/src/faces.h Index: faces.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/faces.h,v retrieving revision 1.14 retrieving revision 1.15 diff -u -p -r1.14 -r1.15 --- faces.h 2005/10/24 10:07:36 1.14 +++ faces.h 2005/11/25 01:42:02 1.15 ＠＠ -117,6 +117,9 ＠＠ struct Lisp_Face typedef struct face_cachel face_cachel; struct face_cachel { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* not NEW_GC */ /* There are two kinds of cachels; those created from a single face and those created by merging more than one face. In the former case, the FACE element specifies the face used. In the latter ＠＠ -221,6 +224,19 ＠＠ struct face_cachel /* #### Of course we should use a bit array or something. */ unsigned char font_updated[NUM_LEADING_BYTES]; }; + +#ifdef NEW_GC +typedef struct face_cachel Lisp_Face_Cachel; + +DECLARE_LRECORD (face_cachel, Lisp_Face_Cachel); + +#define XFACE_CACHEL(x) \ + XRECORD (x, face_cachel, Lisp_Face_Cachel) +#define wrap_face_cachel(p) wrap_record (p, face_cachel) +#define FACE_CACHEL_P(x) RECORDP (x, face_cachel) +#define CHECK_FACE_CACHEL(x) CHECK_RECORD (x, face_cachel) +#define CONCHECK_FACE_CACHEL(x) CONCHECK_RECORD (x, face_cachel) +#endif /* NEW_GC */ DECLARE_LRECORD (face, Lisp_Face); #define XFACE(x) XRECORD (x, face, Lisp_Face) 1.22 +20 -0 XEmacs/xemacs/src/frame-gtk.c Index: frame-gtk.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame-gtk.c,v retrieving revision 1.21 retrieving revision 1.22 diff -u -p -r1.21 -r1.22 --- frame-gtk.c 2005/11/22 11:24:44 1.21 +++ frame-gtk.c 2005/11/25 01:42:02 1.22 ＠＠ -102,11 +102,19 ＠＠ static const struct memory_description g { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("gtk-frame", gtk_frame, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + gtk_frame_data_description_1, + Lisp_Gtk_Frame); +#else /* not NEW_GC */ extern const struct sized_memory_description gtk_frame_data_description; const struct sized_memory_description gtk_frame_data_description = { sizeof (struct gtk_frame), gtk_frame_data_description_1 }; +#endif /* not NEW_GC */  /************************************************************************/ ＠＠ -966,7 +974,11 ＠＠ allocate_gtk_frame_struct (struct frame int i; /* zero out all slots. */ +#ifdef NEW_GC + f->frame_data = alloc_lrecord_type (struct gtk_frame, &lrecord_gtk_frame); +#else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct gtk_frame); +#endif /* not NEW_GC */ /* yeah, except the lisp ones */ FRAME_GTK_ICON_PIXMAP (f) = Qnil; ＠＠ -1342,7 +1354,11 ＠＠ gtk_delete_frame (struct frame *f) if (FRAME_GTK_GEOM_FREE_ME_PLEASE (f)) xfree (FRAME_GTK_GEOM_FREE_ME_PLEASE (f), char *); +#ifdef NEW_GC + mc_free (f->frame_data); +#else /* not NEW_GC */ xfree (f->frame_data, void *); +#endif /* not NEW_GC */ f->frame_data = 0; } ＠＠ -1447,6 +1463,10 ＠＠ gtk_update_frame_external_traits (struct void syms_of_frame_gtk (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (gtk_frame); +#endif /* NEW_GC */ + DEFSYMBOL (Qtext_widget); DEFSYMBOL (Qcontainer_widget); DEFSYMBOL (Qshell_widget); 1.59 +20 -0 XEmacs/xemacs/src/frame-msw.c Index: frame-msw.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame-msw.c,v retrieving revision 1.58 retrieving revision 1.59 diff -u -p -r1.58 -r1.59 --- frame-msw.c 2005/10/25 07:30:42 1.58 +++ frame-msw.c 2005/11/25 01:42:02 1.59 ＠＠ -92,11 +92,19 ＠＠ static const struct memory_description m { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("mswindows-frame", mswindows_frame, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + mswindows_frame_data_description_1, + Lisp_Mswindows_Frame); +#else /* not NEW_GC */ extern const struct sized_memory_description mswindows_frame_data_description; const struct sized_memory_description mswindows_frame_data_description = { sizeof (struct mswindows_frame), mswindows_frame_data_description_1 }; +#endif /* not NEW_GC */ /*---------------------------------------------------------------------*/ /*----- DISPLAY FRAME -----*/ ＠＠ -165,7 +173,12 ＠＠ mswindows_init_frame_1 (struct frame *f, if (!NILP (height)) CHECK_INT (height); +#ifdef NEW_GC + f->frame_data = alloc_lrecord_type (struct mswindows_frame, + &lrecord_mswindows_frame); +#else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct mswindows_frame); +#endif /* not NEW_GC */ FRAME_MSWINDOWS_TARGET_RECT (f) = xnew_and_zero (XEMACS_RECT_WH); FRAME_MSWINDOWS_TARGET_RECT (f)->left = NILP (left) ? -1 : abs (XINT (left)); ＠＠ -340,7 +353,11 ＠＠ mswindows_delete_frame (struct frame *f) #endif ReleaseDC (FRAME_MSWINDOWS_HANDLE (f), FRAME_MSWINDOWS_DC (f)); DestroyWindow (FRAME_MSWINDOWS_HANDLE (f)); +#ifdef NEW_GC + mc_free (f->frame_data); +#else /* not NEW_GC */ xfree (f->frame_data, void *); +#endif /* not NEW_GC */ } f->frame_data = 0; } ＠＠ -1185,6 +1202,9 ＠＠ console_type_create_frame_mswindows (voi void syms_of_frame_mswindows (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (mswindows_frame); +#endif /* NEW_GC */ } void 1.71 +20 -0 XEmacs/xemacs/src/frame-x.c Index: frame-x.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame-x.c,v retrieving revision 1.70 retrieving revision 1.71 diff -u -p -r1.70 -r1.71 --- frame-x.c 2005/04/27 09:01:48 1.70 +++ frame-x.c 2005/11/25 01:42:02 1.71 ＠＠ -77,11 +77,19 ＠＠ static const struct memory_description x { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("x-frame", x_frame, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + x_frame_data_description_1, + Lisp_X_Frame); +#else /* not NEW_GC */ extern const struct sized_memory_description x_frame_data_description; const struct sized_memory_description x_frame_data_description = { sizeof (struct x_frame), x_frame_data_description_1 }; +#endif /* not NEW_GC */ EXFUN (Fx_window_id, 1); ＠＠ -2073,7 +2081,11 ＠＠ static void allocate_x_frame_struct (struct frame *f) { /* zero out all slots. */ +#ifdef NEW_GC + f->frame_data = alloc_lrecord_type (struct x_frame, &lrecord_x_frame); +#else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct x_frame); +#endif /* not NEW_GC */ /* yeah, except the lisp ones */ FRAME_X_LAST_MENUBAR_BUFFER (f) = Qnil; ＠＠ -2642,7 +2654,11 ＠＠ x_delete_frame (struct frame *f) if (f->frame_data) { +#ifdef NEW_GC + mc_free (f->frame_data); +#else /* not NEW_GC */ xfree (f->frame_data, void *); +#endif /* not NEW_GC */ f->frame_data = 0; } } ＠＠ -2720,6 +2736,10 ＠＠ x_update_frame_external_traits (struct f void syms_of_frame_x (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (x_frame); +#endif /* NEW_GC */ + DEFSYMBOL (Qoverride_redirect); DEFSYMBOL (Qx_resource_name); 1.74 +40 -0 XEmacs/xemacs/src/frame.c Index: frame.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/frame.c,v retrieving revision 1.73 retrieving revision 1.74 diff -u -p -r1.73 -r1.74 --- frame.c 2005/10/25 11:16:24 1.73 +++ frame.c 2005/11/25 01:42:03 1.74 ＠＠ -139,12 +139,25 ＠＠ static Ichar_dynarr *title_string_ichar_  +#ifndef NEW_GC extern const struct sized_memory_description gtk_frame_data_description; extern const struct sized_memory_description mswindows_frame_data_description; extern const struct sized_memory_description x_frame_data_description; +#endif /* not NEW_GC */ static const struct memory_description frame_data_description_1 []= { +#ifdef NEW_GC #ifdef HAVE_GTK + { XD_LISP_OBJECT, gtk_console }, +#endif +#ifdef HAVE_MS_WINDOWS + { XD_LISP_OBJECT, mswindows_console }, +#endif +#ifdef HAVE_X_WINDOWS + { XD_LISP_OBJECT, x_console }, +#endif +#else /* not NEW_GC */ +#ifdef HAVE_GTK { XD_BLOCK_PTR, gtk_console, 1, { &gtk_frame_data_description} }, #endif #ifdef HAVE_MS_WINDOWS ＠＠ -153,6 +166,7 ＠＠ static const struct memory_description f #ifdef HAVE_X_WINDOWS { XD_BLOCK_PTR, x_console, 1, { &x_frame_data_description} }, #endif +#endif /* not NEW_GC */ { XD_END } }; ＠＠ -160,6 +174,19 ＠＠ static const struct sized_memory_descrip sizeof (void *), frame_data_description_1 }; +#ifdef NEW_GC +static const struct memory_description expose_ignore_description_1 [] = { + { XD_LISP_OBJECT, offsetof (struct expose_ignore, next) }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("expose-ignore", + expose_ignore, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + expose_ignore_description_1, + struct expose_ignore); +#else /* not NEW_GC */ extern const struct sized_memory_description expose_ignore_description; static const struct memory_description expose_ignore_description_1 [] = { ＠＠ -172,6 +199,7 ＠＠ const struct sized_memory_description ex sizeof (struct expose_ignore), expose_ignore_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description display_line_dynarr_pointer_description_1 []= { { XD_BLOCK_PTR, 0, 1, { &display_line_dynarr_description} }, ＠＠ -189,10 +217,15 ＠＠ static const struct memory_description f { XD_LISP_OBJECT_ARRAY, offsetof (struct frame, slot), size }, #include "frameslots.h" +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (struct frame, subwindow_exposures) }, + { XD_LISP_OBJECT, offsetof (struct frame, subwindow_exposures_tail) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (struct frame, subwindow_exposures), 1, { &expose_ignore_description } }, { XD_BLOCK_PTR, offsetof (struct frame, subwindow_exposures_tail), 1, { &expose_ignore_description } }, +#endif /* not NEW_GC */ #ifdef HAVE_SCROLLBARS { XD_LISP_OBJECT, offsetof (struct frame, sb_vcache) }, ＠＠ -3406,7 +3439,11 ＠＠ change_frame_size (struct frame *f, int --andy. */ MARK_FRAME_SIZE_CHANGED (f); +#ifdef NEW_GC + if (delay || hold_frame_size_changes) +#else /* not NEW_GC */ if (delay || hold_frame_size_changes || gc_in_progress) +#endif /* not NEW_GC */ { f->new_width = newwidth; f->new_height = newheight; ＠＠ -3576,6 +3613,9 ＠＠ void syms_of_frame (void) { INIT_LRECORD_IMPLEMENTATION (frame); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (expose_ignore); +#endif /* NEW_GC */ DEFSYMBOL (Qdelete_frame_hook); DEFSYMBOL (Qselect_frame_hook); 1.55 +12 -0 XEmacs/xemacs/src/glyphs.c Index: glyphs.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/glyphs.c,v retrieving revision 1.54 retrieving revision 1.55 diff -u -p -r1.54 -r1.55 --- glyphs.c 2005/10/24 10:07:37 1.54 +++ glyphs.c 2005/11/25 01:42:04 1.55 ＠＠ -4540,10 +4540,12 ＠＠ reset_frame_subwindow_instance_cache (st expose events that are going to come and ignore them as required. */ +#ifndef NEW_GC struct expose_ignore_blocktype { Blocktype_declare (struct expose_ignore); } *the_expose_ignore_blocktype; +#endif /* not NEW_GC */ int check_for_ignored_expose (struct frame* f, int x, int y, int width, int height) ＠＠ -4574,7 +4576,11 ＠＠ check_for_ignored_expose (struct frame* if (ei == f->subwindow_exposures_tail) f->subwindow_exposures_tail = prev; +#ifdef NEW_GC + mc_free (ei); +#else /* not NEW_GC */ Blocktype_free (the_expose_ignore_blocktype, ei); +#endif /* not NEW_GC */ return 1; } prev = ei; ＠＠ -4589,7 +4595,11 ＠＠ register_ignored_expose (struct frame* f { struct expose_ignore *ei; +#ifdef NEW_GC + ei = alloc_lrecord_type (struct expose_ignore, &lrecord_expose_ignore); +#else /* not NEW_GC */ ei = Blocktype_alloc (the_expose_ignore_blocktype); +#endif /* not NEW_GC */ ei->next = NULL; ei->x = x; ＠＠ -5430,8 +5440,10 ＠＠ image_instantiator_format_create (void) void reinit_vars_of_glyphs (void) { +#ifndef NEW_GC the_expose_ignore_blocktype = Blocktype_new (struct expose_ignore_blocktype); +#endif /* not NEW_GC */ hold_ignored_expose_registration = 0; } 1.41 +28 -0 XEmacs/xemacs/src/glyphs.h Index: glyphs.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/glyphs.h,v retrieving revision 1.40 retrieving revision 1.41 diff -u -p -r1.40 -r1.41 --- glyphs.h 2005/10/24 10:07:37 1.40 +++ glyphs.h 2005/11/25 01:42:04 1.41 ＠＠ -1067,6 +1067,9 ＠＠ void disable_glyph_animated_timeout (int typedef struct glyph_cachel glyph_cachel; struct glyph_cachel { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* not NEW_GC */ Lisp_Object glyph; unsigned int dirty :1; /* I'm copying faces here. I'm not ＠＠ -1082,6 +1085,19 ＠＠ struct glyph_cachel unsigned short descent; }; +#ifdef NEW_GC +typedef struct glyph_cachel Lisp_Glyph_Cachel; + +DECLARE_LRECORD (glyph_cachel, Lisp_Glyph_Cachel); + +#define XGLYPH_CACHEL(x) \ + XRECORD (x, glyph_cachel, Lisp_Glyph_Cachel) +#define wrap_glyph_cachel(p) wrap_record (p, glyph_cachel) +#define GLYPH_CACHEL_P(x) RECORDP (x, glyph_cachel) +#define CHECK_GLYPH_CACHEL(x) CHECK_RECORD (x, glyph_cachel) +#define CONCHECK_GLYPH_CACHEL(x) CONCHECK_RECORD (x, glyph_cachel) +#endif /* NEW_GC */ + #define CONT_GLYPH_INDEX (glyph_index) 0 #define TRUN_GLYPH_INDEX (glyph_index) 1 #define HSCROLL_GLYPH_INDEX (glyph_index) 2 ＠＠ -1179,10 +1195,22 ＠＠ int unmap_subwindow_instance_cache_mappe struct expose_ignore { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ int x, y; int width, height; struct expose_ignore *next; }; + +#ifdef NEW_GC +DECLARE_LRECORD (expose_ignore, struct expose_ignore); +#define XEXPOSE_IGNORE(x) XRECORD (x, expose_ignore, struct expose_ignore) +#define wrap_expose_ignore(p) wrap_record (p, expose_ignore) +#define EXPOSE_IGNOREP(x) RECORDP (x, expose_ignore) +#define CHECK_EXPOSE_IGNORE(x) CHECK_RECORD (x, expose_ignore) +#define CONCHECK_EXPOSE_IGNORE(x) CONCHECK_RECORD (x, expose_ignore) +#endif /* NEW_GC */ int check_for_ignored_expose (struct frame* f, int x, int y, int width, int height); 1.135 +373 -1 XEmacs/xemacs/src/lisp.h Index: lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.134 retrieving revision 1.135 diff -u -p -r1.134 -r1.135 --- lisp.h 2005/11/22 09:02:42 1.134 +++ lisp.h 2005/11/25 01:42:04 1.135 ＠＠ -1253,6 +1253,7 ＠＠ do { \ /* ------------------------ dynamic arrays ------------------- */ +#ifndef NEW_GC #ifdef ERROR_CHECK_STRUCTURES #define Dynarr_declare(type) \ type *base; \ ＠＠ -1380,6 +1381,7 ＠＠ Bytecount Dynarr_memory_usage (void *d, void *stack_like_malloc (Bytecount size); void stack_like_free (void *val); +#endif /* not NEW_GC */ /************************************************************************/ /** Definitions of more complex types **/ ＠＠ -1466,6 +1468,7 ＠＠ typedef struct Lisp_Font_Instance Lisp_F typedef struct Lisp_Image_Instance Lisp_Image_Instance; /* glyphs.h */ typedef struct Lisp_Gui_Item Lisp_Gui_Item; +#ifndef NEW_GC /* ------------------------------- */ /* Dynarr typedefs */ /* ------------------------------- */ ＠＠ -1550,6 +1553,7 ＠＠ typedef struct { Dynarr_declare (struct console_type_entry); } console_type_entry_dynarr; +#endif /* not NEW_GC */ /* ------------------------------- */ /* enum typedefs */ ＠＠ -1666,6 +1670,7 ＠＠ enum Lisp_Type #define XPNTR(x) ((void *) XPNTRVAL(x)) +#ifndef NEW_GC /* WARNING WARNING WARNING. You must ensure on your own that proper GC protection is provided for the elements in this array. */ typedef struct ＠＠ -1677,6 +1682,7 ＠＠ typedef struct { Dynarr_declare (Lisp_Object *); } Lisp_Object_ptr_dynarr; +#endif /* not NEW_GC */ /* Close your eyes now lest you vomit or spontaneously combust ... */ ＠＠ -1707,6 +1713,284 ＠＠ END_C_DECLS BEGIN_C_DECLS +#ifdef NEW_GC +/* ------------------------ dynamic arrays ------------------- */ + +#ifdef ERROR_CHECK_STRUCTURES +#define Dynarr_declare(type) \ + struct lrecord_header header; \ + type *base; \ + const struct lrecord_implementation *lisp_imp; \ + int locked; \ + int elsize; \ + int cur; \ + int largest; \ + int max +#else +#define Dynarr_declare(type) \ + struct lrecord_header header; \ + type *base; \ + const struct lrecord_implementation *lisp_imp; \ + int elsize; \ + int cur; \ + int largest; \ + int max +#endif /* ERROR_CHECK_STRUCTURES */ + +typedef struct dynarr +{ + Dynarr_declare (void); +} Dynarr; + +MODULE_API void *Dynarr_newf (int elsize); +MODULE_API void Dynarr_resize (void *dy, Elemcount size); +MODULE_API void Dynarr_insert_many (void *d, const void *el, int len, int start); +MODULE_API void Dynarr_delete_many (void *d, int start, int len); +MODULE_API void Dynarr_free (void *d); + +MODULE_API void *Dynarr_lisp_newf (int elsize, + const struct lrecord_implementation + *dynarr_imp, + const struct lrecord_implementation *imp); + +#define Dynarr_lisp_new(type, dynarr_imp, imp) \ + ((type##_dynarr *) Dynarr_lisp_newf (sizeof (type), dynarr_imp, imp)) +#define Dynarr_lisp_new2(dynarr_type, type, dynarr_imp, imp) \ + ((dynarr_type *) Dynarr_lisp_newf (sizeof (type)), dynarr_imp, imp) +#define Dynarr_new(type) ((type##_dynarr *) Dynarr_newf (sizeof (type))) +#define Dynarr_new2(dynarr_type, type) \ + ((dynarr_type *) Dynarr_newf (sizeof (type))) +#define Dynarr_at(d, pos) ((d)->base[pos]) +#define Dynarr_atp(d, pos) (&Dynarr_at (d, pos)) +#define Dynarr_begin(d) Dynarr_atp (d, 0) +#define Dynarr_end(d) Dynarr_atp (d, Dynarr_length (d) - 1) +#define Dynarr_sizeof(d) ((d)->cur * (d)->elsize) + +#ifdef ERROR_CHECK_STRUCTURES +DECLARE_INLINE_HEADER ( +Dynarr * +Dynarr_verify_1 (void *d, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + assert_at_line (dy->cur >= 0 && dy->cur <= dy->largest && + dy->largest <= dy->max, file, line); + return dy; +} + +DECLARE_INLINE_HEADER ( +Dynarr * +Dynarr_verify_mod_1 (void *d, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + assert_at_line (!dy->locked, file, line); + assert_at_line (dy->cur >= 0 && dy->cur <= dy->largest && + dy->largest <= dy->max, file, line); + return dy; +} + +#define Dynarr_verify(d) Dynarr_verify_1 (d, __FILE__, __LINE__) +#define Dynarr_verify_mod(d) Dynarr_verify_mod_1 (d, __FILE__, __LINE__) +#define Dynarr_lock(d) (Dynarr_verify_mod (d)->locked = 1) +#define Dynarr_unlock(d) ((d)->locked = 0) +#else +#define Dynarr_verify(d) (d) +#define Dynarr_verify_mod(d) (d) +#define Dynarr_lock(d) +#define Dynarr_unlock(d) +#endif /* ERROR_CHECK_STRUCTURES */ + +#define Dynarr_length(d) (Dynarr_verify (d)->cur) +#define Dynarr_largest(d) (Dynarr_verify (d)->largest) +#define Dynarr_reset(d) (Dynarr_verify_mod (d)->cur = 0) +#define Dynarr_add_many(d, el, len) Dynarr_insert_many (d, el, len, (d)->cur) +#define Dynarr_insert_many_at_start(d, el, len) \ + Dynarr_insert_many (d, el, len, 0) +#define Dynarr_add_literal_string(d, s) Dynarr_add_many (d, s, sizeof (s) - 1) +#define Dynarr_add_lisp_string(d, s, codesys) \ +do { \ + Lisp_Object dyna_ls_s = (s); \ + Lisp_Object dyna_ls_cs = (codesys); \ + Extbyte *dyna_ls_eb; \ + Bytecount dyna_ls_bc; \ + \ + LISP_STRING_TO_SIZED_EXTERNAL (dyna_ls_s, dyna_ls_eb, \ + dyna_ls_bc, dyna_ls_cs); \ + Dynarr_add_many (d, dyna_ls_eb, dyna_ls_bc); \ +} while (0) + +#if 1 +#define Dynarr_add(d, el) \ +do { \ + if (Dynarr_verify_mod (d)->cur >= (d)->max) \ + Dynarr_resize ((d), (d)->cur+1); \ + ((d)->base)[(d)->cur] = (el); \ + \ + if ((d)->lisp_imp) \ + set_lheader_implementation \ + ((struct lrecord_header *)&(((d)->base)[(d)->cur]), \ + (d)->lisp_imp); \ + \ + (d)->cur++; \ + if ((d)->cur > (d)->largest) \ + (d)->largest = (d)->cur; \ +} while (0) +#else +#define Dynarr_add(d, el) ( \ + Dynarr_verify_mod (d)->cur >= (d)->max ? Dynarr_resize ((d), (d)->cur+1) : \ + (void) 0, \ + ((d)->base)[(d)->cur++] = (el), \ + (d)->cur > (d)->largest ? (d)->largest = (d)->cur : (int) 0) +#endif + + +/* The following defines will get you into real trouble if you aren't + careful. But they can save a lot of execution time when used wisely. */ +#define Dynarr_increment(d) (Dynarr_verify_mod (d)->cur++) +#define Dynarr_set_size(d, n) (Dynarr_verify_mod (d)->cur = n) + +#define Dynarr_pop(d) \ + (assert ((d)->cur > 0), Dynarr_verify_mod (d)->cur--, \ + Dynarr_at (d, (d)->cur)) +#define Dynarr_delete(d, i) Dynarr_delete_many (d, i, 1) +#define Dynarr_delete_by_pointer(d, p) \ + Dynarr_delete_many (d, (p) - ((d)->base), 1) + +#define Dynarr_delete_object(d, el) \ +do \ +{ \ + REGISTER int i; \ + for (i = Dynarr_length (d) - 1; i >= 0; i--) \ + { \ + if (el == Dynarr_at (d, i)) \ + Dynarr_delete_many (d, i, 1); \ + } \ +} while (0) + +#ifdef MEMORY_USAGE_STATS +struct overhead_stats; +Bytecount Dynarr_memory_usage (void *d, struct overhead_stats *stats); +#endif + +void *stack_like_malloc (Bytecount size); +void stack_like_free (void *val); + +/* ------------------------------- */ +/* Dynarr typedefs */ +/* ------------------------------- */ + +/* Dynarr typedefs -- basic types first */ + +typedef struct +{ + Dynarr_declare (Ibyte); +} Ibyte_dynarr; + +typedef struct +{ + Dynarr_declare (Extbyte); +} Extbyte_dynarr; + +typedef struct +{ + Dynarr_declare (Ichar); +} Ichar_dynarr; + +typedef struct +{ + Dynarr_declare (char); +} char_dynarr; + +typedef struct +{ + Dynarr_declare (char *); +} char_ptr_dynarr; + +typedef unsigned char unsigned_char; +typedef struct +{ + Dynarr_declare (unsigned char); +} unsigned_char_dynarr; + +typedef unsigned long unsigned_long; +typedef struct +{ + Dynarr_declare (unsigned long); +} unsigned_long_dynarr; + +typedef struct +{ + Dynarr_declare (int); +} int_dynarr; + +typedef struct +{ + Dynarr_declare (Charbpos); +} Charbpos_dynarr; + +typedef struct +{ + Dynarr_declare (Bytebpos); +} Bytebpos_dynarr; + +typedef struct +{ + Dynarr_declare (Charcount); +} Charcount_dynarr; + +typedef struct +{ + Dynarr_declare (Bytecount); +} Bytecount_dynarr; + +/* Dynarr typedefs -- more complex types */ + +typedef struct +{ + Dynarr_declare (struct face_cachel); +} face_cachel_dynarr; + +DECLARE_LRECORD (face_cachel_dynarr, face_cachel_dynarr); +#define XFACE_CACHEL_DYNARR(x) \ + XRECORD (x, face_cachel_dynarr, face_cachel_dynarr) +#define wrap_face_cachel_dynarr(p) wrap_record (p, face_cachel_dynarr) +#define FACE_CACHEL_DYNARRP(x) RECORDP (x, face_cachel_dynarr) +#define CHECK_FACE_CACHEL_DYNARR(x) CHECK_RECORD (x, face_cachel_dynarr) +#define CONCHECK_FACE_CACHEL_DYNARR(x) CONCHECK_RECORD (x, face_cachel_dynarr) + +typedef struct +{ + Dynarr_declare (struct glyph_cachel); +} glyph_cachel_dynarr; + +DECLARE_LRECORD (glyph_cachel_dynarr, glyph_cachel_dynarr); +#define XGLYPH_CACHEL_DYNARR(x) \ + XRECORD (x, glyph_cachel_dynarr, glyph_cachel_dynarr) +#define wrap_glyph_cachel_dynarr(p) wrap_record (p, glyph_cachel_dynarr) +#define GLYPH_CACHEL_DYNARRP(x) RECORDP (x, glyph_cachel_dynarr) +#define CHECK_GLYPH_CACHEL_DYNARR(x) CHECK_RECORD (x, glyph_cachel_dynarr) +#define CONCHECK_GLYPH_CACHEL_DYNARR(x) \ + CONCHECK_RECORD (x, glyph_cachel_dynarr) + +typedef struct +{ + Dynarr_declare (struct console_type_entry); +} console_type_entry_dynarr; + +/* WARNING WARNING WARNING. You must ensure on your own that proper + GC protection is provided for the elements in this array. */ +typedef struct +{ + Dynarr_declare (Lisp_Object); +} Lisp_Object_dynarr; + +typedef struct +{ + Dynarr_declare (Lisp_Object *); +} Lisp_Object_ptr_dynarr; +#endif /* NEW_GC */ + /*------------------------------ unbound -------------------------------*/ /* Qunbound is a special Lisp_Object (actually of type ＠＠ -2282,6 +2566,67 ＠＠ TRUE_LIST_P (Lisp_Object object) /*------------------------------ string --------------------------------*/ +#ifdef NEW_GC +struct Lisp_String_Direct_Data +{ + struct lrecord_header header; + Bytecount size; + Ibyte data[1]; +}; +typedef struct Lisp_String_Direct_Data Lisp_String_Direct_Data; + +DECLARE_MODULE_API_LRECORD (string_direct_data, Lisp_String_Direct_Data); +#define XSTRING_DIRECT_DATA(x) \ + XRECORD (x, string_direct_data, Lisp_String_Direct_Data) +#define wrap_string_direct_data(p) wrap_record (p, string_direct_data) +#define STRING_DIRECT_DATAP(x) RECORDP (x, string_direct_data) +#define CHECK_STRING_DIRECT_DATA(x) CHECK_RECORD (x, string_direct_data) +#define CONCHECK_STRING_DIRECT_DATA(x) CONCHECK_RECORD (x, string_direct_data) + +#define XSTRING_DIRECT_DATA_SIZE(x) XSTRING_DIRECT_DATA (x)->size +#define XSTRING_DIRECT_DATA_DATA(x) XSTRING_DIRECT_DATA (x)->data + + +struct Lisp_String_Indirect_Data +{ + struct lrecord_header header; + Bytecount size; + Ibyte *data; +}; +typedef struct Lisp_String_Indirect_Data Lisp_String_Indirect_Data; + +DECLARE_MODULE_API_LRECORD (string_indirect_data, Lisp_String_Indirect_Data); +#define XSTRING_INDIRECT_DATA(x) \ + XRECORD (x, string_indirect_data, Lisp_String_Indirect_Data) +#define wrap_string_indirect_data(p) wrap_record (p, string_indirect_data) +#define STRING_INDIRECT_DATAP(x) RECORDP (x, string_indirect_data) +#define CHECK_STRING_INDIRECT_DATA(x) CHECK_RECORD (x, string_indirect_data) +#define CONCHECK_STRING_INDIRECT_DATA(x) \ + CONCHECK_RECORD (x, string_indirect_data) + +#define XSTRING_INDIRECT_DATA_SIZE(x) XSTRING_INDIRECT_DATA (x)->size +#define XSTRING_INDIRECT_DATA_DATA(x) XSTRING_INDIRECT_DATA (x)->data + + +#define XSTRING_DATA_SIZE(s) ((s)->indirect)? \ + XSTRING_INDIRECT_DATA_SIZE ((s)->data_object): \ + XSTRING_DIRECT_DATA_SIZE ((s)->data_object) +#define XSTRING_DATA_DATA(s) ((s)->indirect)? \ + XSTRING_INDIRECT_DATA_DATA ((s)->data_object): \ + XSTRING_DIRECT_DATA_DATA ((s)->data_object) + +#define XSET_STRING_DATA_SIZE(s, len) \ + if ((s)->indirect) \ + XSTRING_INDIRECT_DATA_SIZE ((s)->data_object) = len; \ + else \ + XSTRING_DIRECT_DATA_SIZE ((s)->data_object) = len +#define XSET_STRING_DATA_DATA(s, ptr) \ + if ((s)->indirect) \ + XSTRING_INDIRECT_DATA_DATA ((s)->data_object) = ptr; \ + else \ + XSTRING_DIRECT_DATA_DATA ((s)->data_object) = ptr +#endif /* NEW_GC */ + struct Lisp_String { union ＠＠ -2308,8 +2653,13 ＠＠ struct Lisp_String #endif /* not MC_ALLOC */ } v; } u; +#ifdef NEW_GC + int indirect; + Lisp_Object data_object; +#else /* not NEW_GC */ Bytecount size_; Ibyte *data_; +#endif /* not NEW_GC */ Lisp_Object plist; }; typedef struct Lisp_String Lisp_String; ＠＠ -2332,14 +2682,30 ＠＠ DECLARE_MODULE_API_LRECORD (string, Lisp stuff there. */ /* Operations on Lisp_String *'s; only ones left */ +#ifdef NEW_GC +#define set_lispstringp_indirect(s) ((s)->indirect = 1) +#define set_lispstringp_length(s, len) XSET_STRING_DATA_SIZE (s, len) +#define set_lispstringp_data(s, ptr) XSET_STRING_DATA_DATA (s, ptr) +#else /* not NEW_GC */ #define set_lispstringp_length(s, len) ((void) ((s)->size_ = (len))) #define set_lispstringp_data(s, ptr) ((void) ((s)->data_ = (ptr))) +#endif /* not NEW_GC */ /* Operations on strings as Lisp_Objects. Don't manipulate Lisp_String *'s in any new code. */ +#ifdef NEW_GC +#define STRING_DATA_OBJECT(s) ((s)->data_object) +#define XSTRING_DATA_OBJECT(s) (STRING_DATA_OBJECT (XSTRING (s))) +#define XSTRING_LENGTH(s) (XSTRING_DATA_SIZE (XSTRING (s))) +#else /* not NEW_GC */ #define XSTRING_LENGTH(s) (XSTRING (s)->size_) +#endif /* not NEW_GC */ #define XSTRING_PLIST(s) (XSTRING (s)->plist) +#ifdef NEW_GC +#define XSTRING_DATA(s) (XSTRING_DATA_DATA (XSTRING (s))) +#else /* not NEW_GC */ #define XSTRING_DATA(s) (XSTRING (s)->data_ + 0) +#endif /* not NEW_GC */ #define XSTRING_ASCII_BEGIN(s) (XSTRING (s)->u.v.ascii_begin + 0) #define XSET_STRING_LENGTH(s, ptr) set_lispstringp_length (XSTRING (s), ptr) #define XSET_STRING_DATA(s, ptr) set_lispstringp_data (XSTRING (s), ptr) ＠＠ -3624,7 +3990,7 ＠＠ do \ } while (0) extern Lisp_Object_ptr_dynarr *staticpros; - +extern Lisp_Object_ptr_dynarr *staticpros_nodump; #ifdef DEBUG_XEMACS /* Help debug crashes gc-marking a staticpro'ed object. */ ＠＠ -3734,7 +4100,9 ＠＠ MODULE_API Lisp_Object vector3 (Lisp_Obj Lisp_Object make_bit_vector (Elemcount, Lisp_Object); Lisp_Object make_bit_vector_from_byte_vector (unsigned char *, Elemcount); Lisp_Object noseeum_make_marker (void); +#ifndef NEW_GC void garbage_collect_1 (void); +#endif /* not NEW_GC */ MODULE_API Lisp_Object acons (Lisp_Object, Lisp_Object, Lisp_Object); MODULE_API Lisp_Object cons3 (Lisp_Object, Lisp_Object, Lisp_Object); MODULE_API Lisp_Object list1 (Lisp_Object); ＠＠ -3749,7 +4117,9 ＠＠ MODULE_API Lisp_Object list6 (Lisp_Objec DECLARE_DOESNT_RETURN (memory_full (void)); void disksave_object_finalization (void); extern int purify_flag; +#ifndef NEW_GC extern EMACS_INT gc_generation_number[1]; +#endif /* not NEW_GC */ int c_readonly (Lisp_Object); int lisp_readonly (Lisp_Object); MODULE_API void copy_lisp_object (Lisp_Object dst, Lisp_Object src); ＠＠ -3770,6 +4140,7 ＠＠ void free_alist (Lisp_Object); void free_marker (Lisp_Object); int object_dead_p (Lisp_Object); void mark_object (Lisp_Object obj); +#ifndef NEW_GC #ifdef USE_KKCC #ifdef DEBUG_XEMACS void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos); ＠＠ -3783,6 +4154,7 ＠＠ void kkcc_gc_stack_push_lisp_object_1 (L #define kkcc_backtrace() #endif #endif /* USE_KKCC */ +#endif /* not NEW_GC */ int marked_p (Lisp_Object obj); extern int funcall_allocation_flag; extern int need_to_garbage_collect; 1.44 +139 -67 XEmacs/xemacs/src/lrecord.h Index: lrecord.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lrecord.h,v retrieving revision 1.43 retrieving revision 1.44 diff -u -p -r1.43 -r1.44 --- lrecord.h 2005/11/13 10:48:03 1.43 +++ lrecord.h 2005/11/25 01:42:05 1.44 ＠＠ -1,3 +1,5 ＠＠ +#define NEW_GC_REMOVE + /* The "lrecord" structure (header of a compound lisp object). Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1996, 2001, 2002, 2004, 2005 Ben Wing. ＠＠ -217,38 +219,38 ＠＠ enum lrecord_type #### This should be replaced by a symbol_value_magic_p flag in the Lisp_Symbol lrecord_header. */ lrecord_type_symbol_value_forward, /* 0 */ - lrecord_type_symbol_value_varalias, /* 1 */ - lrecord_type_symbol_value_lisp_magic, /* 2 */ - lrecord_type_symbol_value_buffer_local, /* 3 */ + lrecord_type_symbol_value_varalias, + lrecord_type_symbol_value_lisp_magic, + lrecord_type_symbol_value_buffer_local, lrecord_type_max_symbol_value_magic = lrecord_type_symbol_value_buffer_local, - lrecord_type_symbol, /* 4 */ - lrecord_type_subr, /* 5 */ - lrecord_type_cons, /* 6 */ - lrecord_type_vector, /* 7 */ - lrecord_type_string, /* 8 */ + lrecord_type_symbol, + lrecord_type_subr, + lrecord_type_cons, + lrecord_type_vector, + lrecord_type_string, #ifndef MC_ALLOC lrecord_type_lcrecord_list, #endif /* not MC_ALLOC */ - lrecord_type_compiled_function, /* 9 */ - lrecord_type_weak_list, /* 10 */ - lrecord_type_bit_vector, /* 11 */ - lrecord_type_float, /* 12 */ - lrecord_type_hash_table, /* 13 */ - lrecord_type_lstream, /* 14 */ - lrecord_type_process, /* 15 */ - lrecord_type_charset, /* 16 */ - lrecord_type_coding_system, /* 17 */ - lrecord_type_char_table, /* 18 */ - lrecord_type_char_table_entry, /* 19 */ - lrecord_type_range_table, /* 20 */ - lrecord_type_opaque, /* 21 */ - lrecord_type_opaque_ptr, /* 22 */ - lrecord_type_buffer, /* 23 */ - lrecord_type_extent, /* 24 */ - lrecord_type_extent_info, /* 25 */ - lrecord_type_extent_auxiliary, /* 26 */ - lrecord_type_marker, /* 27 */ - lrecord_type_event, /* 28 */ + lrecord_type_compiled_function, + lrecord_type_weak_list, + lrecord_type_bit_vector, + lrecord_type_float, + lrecord_type_hash_table, + lrecord_type_lstream, + lrecord_type_process, + lrecord_type_charset, + lrecord_type_coding_system, + lrecord_type_char_table, + lrecord_type_char_table_entry, + lrecord_type_range_table, + lrecord_type_opaque, + lrecord_type_opaque_ptr, + lrecord_type_buffer, + lrecord_type_extent, + lrecord_type_extent_info, + lrecord_type_extent_auxiliary, + lrecord_type_marker, + lrecord_type_event, #ifdef EVENT_DATA_AS_OBJECTS /* not defined */ lrecord_type_key_data, lrecord_type_button_data, ＠＠ -260,47 +262,79 ＠＠ enum lrecord_type lrecord_type_magic_eval_data, lrecord_type_magic_data, #endif /* EVENT_DATA_AS_OBJECTS */ - lrecord_type_keymap, /* 29 */ - lrecord_type_command_builder, /* 30 */ - lrecord_type_timeout, /* 31 */ - lrecord_type_specifier, /* 32 */ - lrecord_type_console, /* 33 */ - lrecord_type_device, /* 34 */ - lrecord_type_frame, /* 35 */ - lrecord_type_window, /* 36 */ - lrecord_type_window_mirror, /* 37 */ - lrecord_type_window_configuration, /* 38 */ - lrecord_type_gui_item, /* 39 */ - lrecord_type_popup_data, /* 40 */ - lrecord_type_toolbar_button, /* 41 */ - lrecord_type_scrollbar_instance, /* 42 */ - lrecord_type_color_instance, /* 43 */ - lrecord_type_font_instance, /* 44 */ - lrecord_type_image_instance, /* 45 */ - lrecord_type_glyph, /* 46 */ - lrecord_type_face, /* 47 */ - lrecord_type_database, /* 48 */ - lrecord_type_tooltalk_message, /* 49 */ - lrecord_type_tooltalk_pattern, /* 50 */ - lrecord_type_ldap, /* 51 */ - lrecord_type_pgconn, /* 52 */ - lrecord_type_pgresult, /* 53 */ - lrecord_type_devmode, /* 54 */ - lrecord_type_mswindows_dialog_id, /* 55 */ - lrecord_type_case_table, /* 56 */ - lrecord_type_emacs_ffi, /* 57 */ - lrecord_type_emacs_gtk_object, /* 58 */ - lrecord_type_emacs_gtk_boxed, /* 59 */ - lrecord_type_weak_box, /* 60 */ - lrecord_type_ephemeron, /* 61 */ - lrecord_type_bignum, /* 62 */ - lrecord_type_ratio, /* 63 */ - lrecord_type_bigfloat, /* 64 */ + lrecord_type_keymap, + lrecord_type_command_builder, + lrecord_type_timeout, + lrecord_type_specifier, + lrecord_type_console, + lrecord_type_device, + lrecord_type_frame, + lrecord_type_window, + lrecord_type_window_mirror, + lrecord_type_window_configuration, + lrecord_type_gui_item, + lrecord_type_popup_data, + lrecord_type_toolbar_button, + lrecord_type_scrollbar_instance, + lrecord_type_color_instance, + lrecord_type_font_instance, + lrecord_type_image_instance, + lrecord_type_glyph, + lrecord_type_face, + lrecord_type_database, + lrecord_type_tooltalk_message, + lrecord_type_tooltalk_pattern, + lrecord_type_ldap, + lrecord_type_pgconn, + lrecord_type_pgresult, + lrecord_type_devmode, + lrecord_type_mswindows_dialog_id, + lrecord_type_case_table, + lrecord_type_emacs_ffi, + lrecord_type_emacs_gtk_object, + lrecord_type_emacs_gtk_boxed, + lrecord_type_weak_box, + lrecord_type_ephemeron, + lrecord_type_bignum, + lrecord_type_ratio, + lrecord_type_bigfloat, #ifndef MC_ALLOC lrecord_type_free, /* only used for "free" lrecords */ lrecord_type_undefined, /* only used for debugging */ #endif /* not MC_ALLOC */ - lrecord_type_last_built_in_type /* 65 */ /* must be last */ +#ifdef NEW_GC + lrecord_type_string_indirect_data, + lrecord_type_string_direct_data, + lrecord_type_hash_table_entry, + lrecord_type_syntax_cache, + lrecord_type_buffer_text, + lrecord_type_compiled_function_args, + lrecord_type_tty_console, + lrecord_type_stream_console, + lrecord_type_dynarr, + lrecord_type_face_cachel, + lrecord_type_face_cachel_dynarr, + lrecord_type_glyph_cachel, + lrecord_type_glyph_cachel_dynarr, + lrecord_type_x_device, + lrecord_type_gtk_device, + lrecord_type_tty_device, + lrecord_type_mswindows_device, + lrecord_type_msprinter_device, + lrecord_type_x_frame, + lrecord_type_gtk_frame, + lrecord_type_mswindows_frame, + lrecord_type_gap_array_marker, + lrecord_type_gap_array, + lrecord_type_extent_list_marker, + lrecord_type_extent_list, + lrecord_type_stack_of_extents, + lrecord_type_tty_color_instance_data, + lrecord_type_tty_font_instance_data, + lrecord_type_specifier_caching, + lrecord_type_expose_ignore, +#endif /* NEW_GC */ + lrecord_type_last_built_in_type /* must be last */ }; extern MODULE_API int lrecord_type_count; ＠＠ -400,6 +434,12 ＠＠ lrecord_implementations_table[lrecord_ty LHEADER_IMPLEMENTATION (XRECORD_LHEADER (obj)) #define LHEADER_IMPLEMENTATION(lh) lrecord_implementations_table[(lh)->type] +#include "gc.h" + +#ifdef NEW_GC +#include "vdb.h" +#endif /* NEW_GC */ + extern int gc_in_progress; #ifdef MC_ALLOC ＠＠ -407,14 +447,31 ＠＠ extern int gc_in_progress; #ifdef ALLOC_TYPE_STATS void init_lrecord_stats (void); -void inc_lrecord_string_data_stats (Bytecount size); -void dec_lrecord_string_data_stats (Bytecount size); void inc_lrecord_stats (Bytecount size, const struct lrecord_header *h); void dec_lrecord_stats (Bytecount size_including_overhead, const struct lrecord_header *h); +int lrecord_stats_heap_size (void); #endif /* ALLOC_TYPE_STATS */ /* Tell mc-alloc how to call a finalizer. */ +#ifdef NEW_GC +#define MC_ALLOC_CALL_FINALIZER(ptr) \ +{ \ + Lisp_Object MCACF_obj = wrap_pointer_1 (ptr); \ + struct lrecord_header *MCACF_lheader = XRECORD_LHEADER (MCACF_obj); \ + if (XRECORD_LHEADER (MCACF_obj) && LRECORDP (MCACF_obj) \ + && !LRECORD_FREE_P (MCACF_lheader) ) \ + { \ + const struct lrecord_implementation *MCACF_implementation \ + = LHEADER_IMPLEMENTATION (MCACF_lheader); \ + if (MCACF_implementation && MCACF_implementation->finalizer) \ + { \ + GC_STAT_FINALIZED; \ + MCACF_implementation->finalizer (ptr, 0); \ + } \ + } \ +} while (0) +#else /* not NEW_GC */ #define MC_ALLOC_CALL_FINALIZER(ptr) \ { \ Lisp_Object MCACF_obj = wrap_pointer_1 (ptr); \ ＠＠ -428,6 +485,7 ＠＠ void dec_lrecord_stats (Bytecount size_i MCACF_implementation->finalizer (ptr, 0); \ } \ } while (0) +#endif /* not NEW_GC */ /* Tell mc-alloc how to call a finalizer for disksave. */ #define MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE(ptr) \ ＠＠ -952,6 +1010,9 ＠＠ enum memory_description_type { XD_LISP_OBJECT_ARRAY, XD_LISP_OBJECT, +#ifdef NEW_GC + XD_LISP_OBJECT_BLOCK_PTR, +#endif /* NEW_GC */ XD_LO_LINK, XD_OPAQUE_PTR, XD_OPAQUE_PTR_CONVERTIBLE, ＠＠ -1088,6 +1149,14 ＠＠ extern const struct sized_memory_descrip { XD_INT, offsetof (base_type, cur) }, \ { XD_INT_RESET, offsetof (base_type, max), XD_INDIRECT(1, 0) } \ +#ifdef NEW_GC +#define XD_LISP_DYNARR_DESC(base_type, sub_desc) \ + { XD_LISP_OBJECT_BLOCK_PTR, offsetof (base_type, base), \ + XD_INDIRECT(1, 0), {sub_desc} }, \ + { XD_INT, offsetof (base_type, cur) }, \ + { XD_INT_RESET, offsetof (base_type, max), XD_INDIRECT(1, 0) } +#endif /* not NEW_GC */ + /* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size. DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies. */ ＠＠ -1673,6 +1742,9 ＠＠ void old_free_lcrecord (Lisp_Object rec) void *alloc_lrecord (Bytecount size, const struct lrecord_implementation *); + +void *alloc_lrecord_array (Bytecount size, int elemcount, + const struct lrecord_implementation *); #define alloc_lrecord_type(type, lrecord_implementation) \ ((type *) alloc_lrecord (sizeof (type), lrecord_implementation)) 1.6 +539 -309 XEmacs/xemacs/src/mc-alloc.c Index: mc-alloc.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mc-alloc.c,v retrieving revision 1.5 retrieving revision 1.6 diff -u -p -r1.5 -r1.6 --- mc-alloc.c 2005/10/14 01:22:01 1.5 +++ mc-alloc.c 2005/11/25 01:42:05 1.6 ＠＠ -21,17 +21,43 ＠＠ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> + #include "lisp.h" #include "mc-alloc.h" +#include "getpagesize.h" -/*--- configurable values ----------------------------------------------*/ +#if 0 +# define USE_MARK_BITS_FREE_LIST 1 +#endif +#if 1 +# define BLOCKTYPE_ALLOC_PAGE_HEADER 1 +#endif -/* Valid page sizes are powers of 2. */ -#undef PAGE_SIZE /* for FreeBSD */ -#define PAGE_SIZE 2048 +/* Memory protection needs the real system-dependent pagesize. */ +#ifndef WIN32_NATIVE +#include <unistd.h> /* for getpagesize () */ +#endif +#if defined (HAVE_GETPAGESIZE) +# define SYS_PAGE_SIZE getpagesize () +#elif defined (_SC_PAGESIZE) +# define SYS_PAGE_SIZE sysconf (_SC_PAGESIZE) +#elif defined (_SC_PAGE_SIZE) +# define SYS_PAGE_SIZE sysconf (_SC_PAGE_SIZE) +#elif defined(get_page_size) +# define SYS_PAGE_SIZE get_page_size () +#elif defined(PAGESIZE) +# define SYS_PAGE_SIZE PAGESIZE +#elif defined(PAGE_SIZE) +# define SYS_PAGE_SIZE PAGE_SIZE +#else + /* Valid page sizes are powers of 2. */ +# define SYS_PAGE_SIZE 4096 +#endif +/*--- configurable values ----------------------------------------------*/ + /* Definition of size classes */ /* Heap used list constants: In the used heap, it is important to ＠＠ -41,11 +67,19 ＠＠ Boston, MA 02111-1307, USA. */ avoid wasting memory. */ /* Minimum object size in bytes. */ -#define USED_LIST_MIN_OBJECT_SIZE 8 +#if BITS_PER_EMACS_INT > 32 +# define USED_LIST_MIN_OBJECT_SIZE 16 +#else +# define USED_LIST_MIN_OBJECT_SIZE 8 +#endif /* The step size by which the size classes increase (up to upper threshold). This many bytes are mapped to a single used list: */ -#define USED_LIST_LIN_STEP 4 +#if BITS_PER_EMACS_INT > 32 +# define USED_LIST_LIN_STEP 8 +#else +# define USED_LIST_LIN_STEP 4 +#endif /* The upper threshold should always be set to PAGE_SIZE/2, because if a object is larger than PAGE_SIZE/2 there is no room for any other ＠＠ -53,26 +87,7 ＠＠ Boston, MA 02111-1307, USA. */ the multiple pages, since a quick search for free spots is not needed for this kind of pages (because there are no free spots). PAGE_SIZES_DIV_2 defines maximum size of a used space list. */ -#define USED_LIST_UPPER_THRESHOLD PAGE_SIZE_DIV_2 - - -/* Unmanaged memory used list constants: Like in the used heap, it is - important to quickly find a free spot for a new object. Therefore - the size classes of the unmanaged heap are defined by the size of - the cells on the pages. The size classes should match common object - sizes, to avoid wasting memory. */ -/* Minimum object size in bytes. */ -#define UNMANAGED_LIST_MIN_OBJECT_SIZE 8 -/* The step size by which the size classes increase (up to upper - threshold). This many bytes are mapped to a single unmanaged list: */ -#define UNMANAGED_LIST_LIN_STEP 4 -/* The upper threshold should always be set to PAGE_SIZE/2, because if - a object is larger than PAGE_SIZE/2 there is no room for any other - object on this page. Objects this big are kept in the page list of - the multiple pages, since a quick search for free spots is not - needed for this kind of pages (because there are no free spots). - PAGE_SIZES defines maximum size of a unmanaged space list. */ -#define UNMANAGED_LIST_UPPER_THRESHOLD PAGE_SIZE_DIV_2 +#define USED_LIST_UPPER_THRESHOLD PAGE_SIZE_DIV_2 /* Heap free list constants: In the unused heap, the size of ＠＠ -93,6 +108,18 ＠＠ Boston, MA 02111-1307, USA. */ #define FREE_LIST_UPPER_THRESHOLD 256 +/* used heap list count */ +#define N_USED_PAGE_LISTS (((USED_LIST_UPPER_THRESHOLD \ + - USED_LIST_MIN_OBJECT_SIZE) \ + / USED_LIST_LIN_STEP) + 1 ) + 1 + +/* free heap list count */ +#define N_FREE_PAGE_LISTS (((FREE_LIST_UPPER_THRESHOLD \ + - FREE_LIST_LOWER_THRESHOLD) \ + / FREE_LIST_LIN_STEP) \ + + FREE_LIST_LOWER_THRESHOLD) + + /* Maximum number of separately added heap sections. */ #if BITS_PER_EMACS_INT > 32 # define MAX_HEAP_SECTS 2048 ＠＠ -103,7 +130,7 ＠＠ Boston, MA 02111-1307, USA. */ /* Heap growth constants. Heap increases by any number between the boundaries (unit is PAGE_SIZE). */ -#define MIN_HEAP_INCREASE 32 +#define MIN_HEAP_INCREASE 256 #define MAX_HEAP_INCREASE 256 /* not used */ /* Every heap growth is calculated like this: ＠＠ -120,96 +147,22 ＠＠ Boston, MA 02111-1307, USA. */ #define ZERO_MEM 1 - - -/*--- calculations done by macros --------------------------------------*/ - #ifndef CHAR_BIT /* should be included by limits.h */ # define CHAR_BIT BITS_PER_CHAR #endif -#if PAGE_SIZE == 512 -# define CPP_LOG_PAGE_SIZE 9 -#endif -#if PAGE_SIZE == 1024 -# define CPP_LOG_PAGE_SIZE 10 -#endif -#if PAGE_SIZE == 2048 -# define CPP_LOG_PAGE_SIZE 11 -#endif -#if PAGE_SIZE == 4096 -# define CPP_LOG_PAGE_SIZE 12 -#endif -#if PAGE_SIZE == 8192 -# define CPP_LOG_PAGE_SIZE 13 -#endif -#if PAGE_SIZE == 16384 -# define CPP_LOG_PAGE_SIZE 14 -#endif -#ifndef CPP_LOG_PAGE_SIZE ---> fix PAGE_SIZE -#endif -#undef PAGE_SIZE -#define CPP_PAGE_SIZE (1 << CPP_LOG_PAGE_SIZE) -#define LOG_PAGE_SIZE ((EMACS_INT) CPP_LOG_PAGE_SIZE) -#define PAGE_SIZE ((EMACS_INT) CPP_PAGE_SIZE) -#define PAGE_SIZE_DIV_2 (PAGE_SIZE >> 1) - - -/* NOT USED ANYMORE */ -#ifdef USE_EXPONENTIAL_USED_LIST_GROWTH -/* used heap list logarithms */ -#if USED_LIST_LOWER_THRESHOLD == 8 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 3 -#endif -#if USED_LIST_LOWER_THRESHOLD == 16 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 4 -#endif -#if USED_LIST_LOWER_THRESHOLD == 32 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 5 -#endif -#if USED_LIST_LOWER_THRESHOLD == 64 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 6 -#endif -#if USED_LIST_LOWER_THRESHOLD == 128 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 7 -#endif -#if USED_LIST_LOWER_THRESHOLD == 256 -# define CPP_LOG_USED_LIST_LOWER_THRESHOLD 8 -#endif -#ifndef CPP_LOG_USED_LIST_LOWER_THRESHOLD ---> fix USED_LIST_LOWER_THRESHOLD -#endif -#define LOG_USED_LIST_LOWER_THRESHOLD CPP_LOG_USED_LIST_LOWER_THRESHOLD -#endif /* USE_EXPONENTIAL_USED_LIST_GROWTH */ -/* used heap list count */ -#define N_USED_PAGE_LISTS (((USED_LIST_UPPER_THRESHOLD \ - - USED_LIST_MIN_OBJECT_SIZE) \ - / USED_LIST_LIN_STEP) + 1 ) + 1 + +/*--- values depending on PAGE_SIZE ------------------------------------*/ -/* unmanaged memory list count */ -#define N_UNMANAGED_PAGE_LISTS (((UNMANAGED_LIST_UPPER_THRESHOLD \ - - UNMANAGED_LIST_MIN_OBJECT_SIZE) \ - / UNMANAGED_LIST_LIN_STEP) + 1 ) + 1 - -/* NOT USED ANYMORE */ -#ifdef USE_EXPONENTIAL_USED_LIST_GROWTH -#define N_USED_PAGE_LISTS_LIN (((USED_LIST_LOWER_THRESHOLD \ - - USED_LIST_MIN_OBJECT_SIZE) \ - / USED_LIST_LIN_STEP) + 1 ) -#define N_USED_PAGE_LISTS_EXP \ - (LOG_PAGE_SIZE - LOG_USED_LIST_LOWER_THRESHOLD) - -#define N_USED_PAGE_LISTS \ - (N_USED_PAGE_LISTS_LIN + N_USED_PAGE_LISTS_EXP + 1) -#endif /* USE_EXPONENTIAL_USED_LIST_GROWTH */ +/* initialized in init_mc_allocator () */ +static EMACS_INT log_page_size; +static EMACS_INT page_size_div_2; -/* free heap list count */ -#define N_FREE_PAGE_LISTS (((FREE_LIST_UPPER_THRESHOLD \ - - FREE_LIST_LOWER_THRESHOLD) \ - / FREE_LIST_LIN_STEP) \ - + FREE_LIST_LOWER_THRESHOLD) +#undef PAGE_SIZE +#define PAGE_SIZE SYS_PAGE_SIZE +#define LOG_PAGE_SIZE log_page_size +#define PAGE_SIZE_DIV_2 page_size_div_2 /* Constants for heap address to page header mapping. */ ＠＠ -237,8 +190,7 ＠＠ Boston, MA 02111-1307, USA. */  /*--- structs and typedefs ---------------------------------------------*/ -/* Links the free lists (mark_bit_free_list, page_header_free_list, - cell free list). */ +/* Links the free lists (mark_bit_free_list and cell free list). */ typedef struct free_link { struct lrecord_header lheader; ＠＠ -246,7 +198,7 ＠＠ typedef struct free_link } free_link; -/* Header for pages. They are hold in a doubly linked list. */ +/* Header for pages. They are held in a doubly linked list. */ typedef struct page_header { struct page_header *next; /* next page_header */ ＠＠ -263,7 +215,11 ＠＠ typedef struct page_header mark_bits holds the pointer to this area. Is the number of objects smaller than BITS_PER_EMACS_INT, the mark bits are held in the mark_bit EMACS_INT directly, without an additional indirection. */ - char *mark_bits; /* pointer to mark bits */ + unsigned int black_bit:1; /* objects on page are black */ + unsigned int dirty_bit:1; /* page is dirty */ + unsigned int protection_bit:1; /* page is write protected */ + unsigned int array_bit:1; /* page holds arrays */ + Rawbyte *mark_bits; /* pointer to mark bits */ void *heap_space; /* pointer to heap, where objects are stored */ } page_header; ＠＠ -272,7 +228,6 ＠＠ typedef struct page_header /* Different list types. */ enum list_type_enum { USED_LIST, - UNMANAGED_LIST, FREE_LIST }; ＠＠ -339,20 +294,19 ＠＠ typedef struct mc_allocator_globals_type /* Holds all allocated pages, each object size class in its separate list, to guarantee fast allocation on partially filled pages. */ - page_list_header used_heap_pages[N_USED_PAGE_LISTS]; - - /* Holds all unmanaged pages. */ - page_list_header unmanaged_heap_pages[N_UNMANAGED_PAGE_LISTS]; + page_list_header *used_heap_pages; /* Holds all free pages in the heap. N multiples of PAGE_SIZE are kept on the Nth free list. Contiguos pages are coalesced. */ page_list_header free_heap_pages[N_FREE_PAGE_LISTS]; /* ptr lookup table */ - level_2_lookup_tree *ptr_lookup_table[LEVEL1_SIZE]; + level_2_lookup_tree **ptr_lookup_table; +#ifndef BLOCKTYPE_ALLOC_PAGE_HEADER /* page header free list */ free_link *page_header_free_list; +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ #ifdef MEMORY_USAGE_STATS EMACS_INT malloced_bytes; ＠＠ -369,9 +323,6 ＠＠ mc_allocator_globals_type mc_allocator_g #define USED_HEAP_PAGES(i) \ ((page_list_header*) &mc_allocator_globals.used_heap_pages[i]) -#define UNMANAGED_HEAP_PAGES(i) \ - ((page_list_header*) &mc_allocator_globals.unmanaged_heap_pages[i]) - #define FREE_HEAP_PAGES(i) \ ((page_list_header*) &mc_allocator_globals.free_heap_pages[i]) ＠＠ -398,6 +349,10 ＠＠ mc_allocator_globals_type mc_allocator_g # define PH_CELL_SIZE(ph) PH (ph)->cell_size # define PH_CELLS_ON_PAGE(ph) PH (ph)->cells_on_page # define PH_CELLS_USED(ph) PH (ph)->cells_used +# define PH_BLACK_BIT(ph) PH (ph)->black_bit +# define PH_DIRTY_BIT(ph) PH (ph)->dirty_bit +# define PH_PROTECTION_BIT(ph) PH (ph)->protection_bit +# define PH_ARRAY_BIT(ph) PH (ph)->array_bit # define PH_MARK_BITS(ph) PH (ph)->mark_bits # define PH_HEAP_SPACE(ph) PH (ph)->heap_space #define PH_LIST_TYPE(ph) PLH_LIST_TYPE (PH_PLH (ph)) ＠＠ -412,7 +367,9 ＠＠ mc_allocator_globals_type mc_allocator_g #define HEAP_SECTION(index) mc_allocator_globals.heap_sections[index] #define N_HEAP_SECTIONS mc_allocator_globals.n_heap_sections +#ifndef BLOCKTYPE_ALLOC_PAGE_HEADER #define PAGE_HEADER_FREE_LIST mc_allocator_globals.page_header_free_list +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ #define NEXT_FREE(free_list) ((free_link*) free_list)->next_free #define FREE_LIST(free_list) (free_link*) (free_list) ＠＠ -444,9 +401,13 ＠＠ mc_allocator_globals_type mc_allocator_g #define PH_ON_USED_LIST_P(ph) \ (ph && PH_PLH (ph) && (PLH_LIST_TYPE (PH_PLH (ph)) == USED_LIST)) -#define PH_ON_UNMANAGED_LIST_P(ph) \ - (ph && PH_PLH (ph) && (PLH_LIST_TYPE (PH_PLH (ph)) == UNMANAGED_LIST)) +/* Number of mark bits: minimum 1, maximum 8. */ +#ifdef NEW_GC +#define N_MARK_BITS 2 +#else /* not NEW_GC */ +#define N_MARK_BITS 1 +#endif /* not NEW_GC */  ＠＠ -455,12 +416,6 ＠＠ mc_allocator_globals_type mc_allocator_g /************************************************************************/ -/* ###TODO### */ -#if 1 -# define ALLOC_MB_UNMANAGED 1 -#endif - - /*--- misc functions ---------------------------------------------------*/ /* moved here from alloc.c */ ＠＠ -483,7 +438,7 ＠＠ deadbeef_memory (void *ptr, Bytecount si static void visit_all_used_page_headers (void (*f) (page_header *ph)) { - int i; + EMACS_INT i; for (i = 0; i < N_USED_PAGE_LISTS; i++) if (PLH_FIRST (USED_HEAP_PAGES (i))) { ＠＠ -507,7 +462,7 ＠＠ visit_all_used_page_headers (void (*f) ( static void set_lookup_table (void *ptr, page_header *ph) { - int l1_index = L1_INDEX (ptr); + EMACS_INT l1_index = L1_INDEX (ptr); level_2_lookup_tree *l2 = PTR_LOOKUP_TABLE (l1_index); #ifdef USE_HASH_TABLE while ((l2) && (LEVEL2_KEY (l2) != l1_index)) ＠＠ -537,7 +492,7 ＠＠ set_lookup_table (void *ptr, page_header static void unset_lookup_table (void *ptr) { - int l1_index = L1_INDEX (ptr); + EMACS_INT l1_index = L1_INDEX (ptr); level_2_lookup_tree *l2 = PTR_LOOKUP_TABLE (l1_index); #ifdef USE_HASH_TABLE while ((l2) && (LEVEL2_KEY (l2) != l1_index)) ＠＠ -554,7 +509,7 ＠＠ unset_lookup_table (void *ptr) static page_header * get_page_header_internal (void *ptr) { - int l1_index = L1_INDEX (ptr); + EMACS_INT l1_index = L1_INDEX (ptr); level_2_lookup_tree *l2 = PTR_LOOKUP_TABLE (l1_index); #ifdef USE_HASH_TABLE while ((l2) && (LEVEL2_KEY (l2) != l1_index)) ＠＠ -569,7 +524,7 ＠＠ get_page_header_internal (void *ptr) static page_header * get_page_header (void *ptr) { - int l1_index = L1_INDEX (ptr); + EMACS_INT l1_index = L1_INDEX (ptr); level_2_lookup_tree *l2 = PTR_LOOKUP_TABLE (l1_index); assert (l2); #ifdef USE_HASH_TABLE ＠＠ -580,14 +535,14 ＠＠ get_page_header (void *ptr) return LEVEL2 (l2, L2_INDEX (ptr)); } - /* Returns the mark bit index of a given heap address. */ static EMACS_INT get_mark_bit_index (void *ptr, page_header *ph) { EMACS_INT cell_size = PH_CELL_SIZE (ph); if (cell_size) - return (((EMACS_INT) ptr - (EMACS_INT)(PH_HEAP_SPACE (ph))) / cell_size); + return (((EMACS_INT) ptr - (EMACS_INT)(PH_HEAP_SPACE (ph))) / cell_size) + * N_MARK_BITS; else /* only one object on page */ return 0; } ＠＠ -597,9 +552,9 ＠＠ get_mark_bit_index (void *ptr, page_head static void add_pages_to_lookup_table (page_header *ph, EMACS_INT n_pages) { - char *p = (char*) PH_HEAP_SPACE (ph); + Rawbyte *p = (Rawbyte *) PH_HEAP_SPACE (ph); EMACS_INT end_of_section = (EMACS_INT) p + (PAGE_SIZE * n_pages); - for (p = (char*) PH_HEAP_SPACE (ph); + for (p = (Rawbyte *) PH_HEAP_SPACE (ph); (EMACS_INT) p < end_of_section; p += PAGE_SIZE) set_lookup_table (p, ph); } ＠＠ -609,7 +564,7 ＠＠ add_pages_to_lookup_table (page_header * static void init_lookup_table (void) { - int i; + EMACS_INT i; for (i = 0; i < LEVEL1_SIZE; i++) PTR_LOOKUP_TABLE (i) = 0; } ＠＠ -619,35 +574,32 ＠＠ init_lookup_table (void)  /*--- mark bits --------------------------------------------------------*/ -/* Number of mark bits: minimum 1, maximum 8. */ -#define N_MARK_BITS 1 - /*--- bit operations --- */ /* Allocates a bit array of length bits. */ -static char * +static Rawbyte * alloc_bit_array(size_t bits) { -#ifdef ALLOC_MB_UNMANAGED - size_t size = ((bits + CHAR_BIT - 1) / CHAR_BIT) * sizeof(char); + Rawbyte *bit_array; +#ifdef USE_MARK_BITS_FREE_LIST + size_t size = ((bits + CHAR_BIT - 1) / CHAR_BIT) * sizeof (Rawbyte); +#else /* not USE_MARK_BITS_FREE_LIST */ + size_t size = + ALIGN_FOR_TYPE (((bits + CHAR_BIT - 1) / CHAR_BIT) * sizeof (Rawbyte), + Rawbyte *); +#endif /* not USE_MARK_BITS_FREE_LIST */ if (size < sizeof (free_link)) size = sizeof (free_link); - return (char *) mc_alloc_unmanaged (size); -#else /* not ALLOC_MB_UNMANAGED */ - size_t size = ((bits + CHAR_BIT - 1) / CHAR_BIT) * sizeof(char); - char *bit_array; - if (size < sizeof (free_link)) size = sizeof (free_link); - bit_array = (char*) xmalloc_and_zero (size); #ifdef MEMORY_USAGE_STATS MC_MALLOCED_BYTES += malloced_storage_size (0, size, 0); #endif + bit_array = (Rawbyte *) xmalloc_and_zero (size); return bit_array; -#endif /* not ALLOC_MB_UNMANAGED */ } /* Returns the bit value at pos. */ static EMACS_INT -get_bit (char *bit_array, EMACS_INT pos) +get_bit (Rawbyte *bit_array, EMACS_INT pos) { #if N_MARK_BITS > 1 EMACS_INT result = 0; ＠＠ -656,8 +608,8 ＠＠ get_bit (char *bit_array, EMACS_INT pos) bit_array += pos / CHAR_BIT; #if N_MARK_BITS > 1 for (i = 0; i < N_MARK_BITS; i++) - result |= (*bit_array & (1 << ((pos + i) % CHAR_BIT))); - return result >> pos; + result |= ((*bit_array & (1 << ((pos + i) % CHAR_BIT))) != 0) << i; + return result; #else return (*bit_array & (1 << (pos % CHAR_BIT))) != 0; #endif ＠＠ -666,10 +618,9 ＠＠ get_bit (char *bit_array, EMACS_INT pos) /* Bit_Arrays bit at pos to val. */ static void -set_bit(char *bit_array, EMACS_INT pos, EMACS_INT val) +set_bit (Rawbyte *bit_array, EMACS_INT pos, EMACS_INT val) { #if N_MARK_BITS > 1 - EMACS_INT result = 0; EMACS_INT i; #endif bit_array += pos / CHAR_BIT; ＠＠ -689,21 +640,23 ＠＠ set_bit(char *bit_array, EMACS_INT pos, /*--- mark bit functions ---*/ -#define USE_PNTR_MARK_BITS(ph) (PH_CELLS_ON_PAGE (ph) > BITS_PER_EMACS_INT) -#define USE_WORD_MARK_BITS(ph) (PH_CELLS_ON_PAGE (ph) <= BITS_PER_EMACS_INT) +#define USE_PNTR_MARK_BITS(ph) \ + ((PH_CELLS_ON_PAGE (ph) * N_MARK_BITS) > BITS_PER_EMACS_INT) +#define USE_WORD_MARK_BITS(ph) \ + ((PH_CELLS_ON_PAGE (ph) * N_MARK_BITS) <= BITS_PER_EMACS_INT) -#define GET_BIT_WORD(b, p) get_bit ((char*) &b, p) +#define GET_BIT_WORD(b, p) get_bit ((Rawbyte *) &b, p) #define GET_BIT_PNTR(b, p) get_bit (b, p) -#define SET_BIT_WORD(b, p, v) set_bit ((char*) &b, p, v) +#define SET_BIT_WORD(b, p, v) set_bit ((Rawbyte *) &b, p, v) #define SET_BIT_PNTR(b, p, v) set_bit (b, p, v) #define ZERO_MARK_BITS_WORD(ph) PH_MARK_BITS (ph) = 0 -#define ZERO_MARK_BITS_PNTR(ph) \ -do { \ - memset (PH_MARK_BITS (ph), '\0', \ - (PH_CELLS_ON_PAGE (ph) + CHAR_BIT - 1) \ - / CHAR_BIT * sizeof(char)); \ +#define ZERO_MARK_BITS_PNTR(ph) \ +do { \ + memset (PH_MARK_BITS (ph), '\0', \ + ((PH_CELLS_ON_PAGE (ph) * N_MARK_BITS) \ + + CHAR_BIT - 1) / CHAR_BIT * sizeof (Rawbyte)); \ } while (0) #define GET_BIT(bit, ph, p) \ ＠＠ -733,17 +686,21 ＠＠ do { \ /* Allocates mark-bit space either from a free list or from the OS for the given page header. */ -static char * +static Rawbyte * alloc_mark_bits (page_header *ph) { - char *result; + Rawbyte *result; +#ifdef USE_MARK_BITS_FREE_LIST if (PH_MARK_BIT_FREE_LIST (ph) == 0) - result = (char*) alloc_bit_array (PH_CELLS_ON_PAGE (ph) * N_MARK_BITS); + result = (Rawbyte *) alloc_bit_array (PH_CELLS_ON_PAGE (ph) * N_MARK_BITS); else { - result = (char*) PH_MARK_BIT_FREE_LIST (ph); + result = (Rawbyte *) PH_MARK_BIT_FREE_LIST (ph); PH_MARK_BIT_FREE_LIST (ph) = NEXT_FREE (result); } +#else /* not USE_MARK_BITS_FREE_LIST */ + result = (Rawbyte *) alloc_bit_array (PH_CELLS_ON_PAGE (ph) * N_MARK_BITS); +#endif /* not USE_MARK_BITS_FREE_LIST */ return result; } ＠＠ -752,15 +709,13 ＠＠ alloc_mark_bits (page_header *ph) static void free_mark_bits (page_header *ph) { -#ifdef ALLOC_MB_UNMANAGED +#ifdef USE_MARK_BITS_FREE_LIST + NEXT_FREE (PH_MARK_BITS (ph)) = PH_MARK_BIT_FREE_LIST (ph); + PH_MARK_BIT_FREE_LIST (ph) = FREE_LIST (PH_MARK_BITS (ph)); +#else /* not USE_MARK_BITS_FREE_LIST */ if (PH_MARK_BITS (ph)) - mc_free (PH_MARK_BITS (ph)); -#else /* not ALLOC_MB_UNMANAGED */ - if (PH_MARK_BITS (ph)) { - NEXT_FREE (PH_MARK_BITS (ph)) = PH_MARK_BIT_FREE_LIST (ph); - PH_MARK_BIT_FREE_LIST (ph) = FREE_LIST (PH_MARK_BITS (ph)); - } -#endif /* not ALLOC_MB_UNMANAGED */ + free (PH_MARK_BITS (ph)); +#endif /* not USE_MARK_BITS_FREE_LIST */ } ＠＠ -818,6 +773,11 ＠＠ set_mark_bit (void *ptr, EMACS_INT value assert (ph && PH_ON_USED_LIST_P (ph)); if (ph) { +#ifdef NEW_GC + if (value == BLACK) + if (!PH_BLACK_BIT (ph)) + PH_BLACK_BIT (ph) = 1; +#endif /* NEW_GC */ SET_BIT (ph, get_mark_bit_index (ptr, ph), value); } } ＠＠ -827,11 +787,29 ＠＠ set_mark_bit (void *ptr, EMACS_INT value  /*--- page header functions --------------------------------------------*/ +#ifdef BLOCKTYPE_ALLOC_PAGE_HEADER +#include "blocktype.h" + +struct page_header_blocktype +{ + Blocktype_declare (page_header); +} *the_page_header_blocktype; +#endif /* BLOCKTYPE_ALLOC_PAGE_HEADER */ + /* Allocates a page header either from a free list or from the OS. */ static page_header * alloc_page_header (void) { +#ifdef BLOCKTYPE_ALLOC_PAGE_HEADER page_header *result; +#ifdef MEMORY_USAGE_STATS + MC_MALLOCED_BYTES += malloced_storage_size (0, sizeof (page_header), 0); +#endif + result = Blocktype_alloc (the_page_header_blocktype); + ZERO_PAGE_HEADER (result); + return result; +#else /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ + page_header *result; if (PAGE_HEADER_FREE_LIST == 0) { result = ＠＠ -839,7 +817,6 ＠＠ alloc_page_header (void) #ifdef MEMORY_USAGE_STATS MC_MALLOCED_BYTES += malloced_storage_size (0, sizeof (page_header), 0); #endif - } else { ＠＠ -847,6 +824,7 ＠＠ alloc_page_header (void) PAGE_HEADER_FREE_LIST = NEXT_FREE (result); } return result; +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ } ＠＠ -854,11 +832,15 ＠＠ alloc_page_header (void) static void free_page_header (page_header *ph) { +#ifdef BLOCKTYPE_ALLOC_PAGE_HEADER + Blocktype_free (the_page_header_blocktype, ph); +#else /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ #if ZERO_MEM ZERO_PAGE_HEADER (ph); #endif NEXT_FREE (ph) = PAGE_HEADER_FREE_LIST; PAGE_HEADER_FREE_LIST = FREE_LIST (ph); +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ } ＠＠ -940,14 +922,22 ＠＠ static int get_used_list_index (size_t size) { if (size <= USED_LIST_MIN_OBJECT_SIZE) - return 0; - if (size <= USED_LIST_UPPER_THRESHOLD) - return ((size - USED_LIST_MIN_OBJECT_SIZE - 1) - / USED_LIST_LIN_STEP) + 1; + { + // printf ("size %d -> index %d\n", size, 0); + return 0; + } + if (size <= (size_t) USED_LIST_UPPER_THRESHOLD) + { + // printf ("size %d -> index %d\n", size, + // ((size - USED_LIST_MIN_OBJECT_SIZE - 1) + // / USED_LIST_LIN_STEP) + 1); + return ((size - USED_LIST_MIN_OBJECT_SIZE - 1) + / USED_LIST_LIN_STEP) + 1; + } + // printf ("size %d -> index %d\n", size, N_USED_PAGE_LISTS - 1); return N_USED_PAGE_LISTS - 1; } - /* Returns the size of the used heap list according to given index. */ static size_t get_used_list_size_value (int used_index) ＠＠ -958,32 +948,8 ＠＠ get_used_list_size_value (int used_index } -/* Returns the index of the used heap list according to given size. */ -static int -get_unmanaged_list_index (size_t size) -{ - if (size <= UNMANAGED_LIST_MIN_OBJECT_SIZE) - return 0; - if (size <= UNMANAGED_LIST_UPPER_THRESHOLD) - return ((size - UNMANAGED_LIST_MIN_OBJECT_SIZE - 1) - / UNMANAGED_LIST_LIN_STEP) + 1; - return N_UNMANAGED_PAGE_LISTS - 1; -} - - -/* Returns the size of the unmanaged heap list according to given index. */ -static size_t -get_unmanaged_list_size_value (int unmanaged_index) -{ - if (unmanaged_index < N_UNMANAGED_PAGE_LISTS - 1) - return (unmanaged_index * UNMANAGED_LIST_LIN_STEP) - + UNMANAGED_LIST_MIN_OBJECT_SIZE; - return 0; -} - - /* Returns the index of the free heap list according to given size. */ -static int +static EMACS_INT get_free_list_index (EMACS_INT n_pages) { if (n_pages == 0) ＠＠ -1000,7 +966,7 ＠＠ get_free_list_index (EMACS_INT n_pages) /* Returns the size in number of pages of the given free list at index. */ static size_t -get_free_list_size_value (int free_index) +get_free_list_size_value (EMACS_INT free_index) { if (free_index < FREE_LIST_LOWER_THRESHOLD) return free_index + 1; ＠＠ -1038,8 +1004,8 ＠＠ mc_alloced_storage_size (Bytecount claim static EMACS_INT free_heap_section (page_header *ph) { - int i; - int removed = 0; + EMACS_INT i; + EMACS_INT removed = 0; for (i = 0; i < N_HEAP_SECTIONS; i++) if (!removed) { ＠＠ -1220,22 +1186,23 ＠＠ expand_heap (EMACS_INT needed_pages) /*--- used heap functions ----------------------------------------------*/ /* Installs initial free list. */ static void -install_cell_free_list (page_header *ph) +install_cell_free_list (page_header *ph, EMACS_INT elemcount) { - char *p; - int i; + Rawbyte *p; + EMACS_INT i; EMACS_INT cell_size = PH_CELL_SIZE (ph); /* write initial free list if cell_size is < PAGE_SIZE */ - p = (char *) PH_HEAP_SPACE (ph); + p = (Rawbyte *) PH_HEAP_SPACE (ph); for (i = 0; i < PH_CELLS_ON_PAGE (ph) - 1; i++) { #ifdef ERROR_CHECK_GC assert (!LRECORD_FREE_P (p)); MARK_LRECORD_AS_FREE (p); #endif - NEXT_FREE (p) = FREE_LIST (p + cell_size); + if (elemcount == 1) + NEXT_FREE (p) = FREE_LIST (p + cell_size); set_lookup_table (p, ph); - p += cell_size; + p += cell_size; } #ifdef ERROR_CHECK_GC assert (!LRECORD_FREE_P (p)); ＠＠ -1263,7 +1230,7 ＠＠ remove_cell_free_list (page_header *ph) /* Installs a new page and hooks it into given page_list_header. */ static page_header * install_page_in_used_list (page_header *ph, page_list_header *plh, - size_t size, int managed) + size_t size, EMACS_INT elemcount) { /* add to list */ add_page_header_to_plh (ph, plh); ＠＠ -1273,16 +1240,21 ＠＠ install_page_in_used_list (page_header * PH_CELL_SIZE (ph) = PLH_SIZE (plh); else PH_CELL_SIZE (ph) = size; - PH_CELLS_ON_PAGE (ph) = (PAGE_SIZE * PH_N_PAGES (ph)) / PH_CELL_SIZE (ph); + if (elemcount == 1) + PH_CELLS_ON_PAGE (ph) = (PAGE_SIZE * PH_N_PAGES (ph)) / PH_CELL_SIZE (ph); + else + { + PH_CELLS_ON_PAGE (ph) = elemcount; + PH_ARRAY_BIT (ph) = 1; + } /* init cell count */ PH_CELLS_USED (ph) = 0; /* install mark bits and initialize cell free list */ - if (managed) - install_mark_bits (ph); + install_mark_bits (ph); - install_cell_free_list (ph); + install_cell_free_list (ph, elemcount); #ifdef MEMORY_USAGE_STATS PLH_TOTAL_CELLS (plh) += PH_CELLS_ON_PAGE (ph); ＠＠ -1299,6 +1271,11 ＠＠ remove_page_from_used_list (page_header { page_list_header *plh = PH_PLH (ph); +#ifdef NEW_GC + if (gc_in_progress && PH_PROTECTION_BIT (ph)) ABORT(); + /* cleanup: remove memory protection, zero page_header bits. */ +#endif /* not NEW_GC */ + #ifdef MEMORY_USAGE_STATS PLH_TOTAL_CELLS (plh) -= PH_CELLS_ON_PAGE (ph); PLH_TOTAL_SPACE (plh) -= PAGE_SIZE * PH_N_PAGES (ph); ＠＠ -1377,7 +1354,7 ＠＠ static page_header * allocate_page_from_free_list (EMACS_INT needed_pages) { page_header *ph = 0; - int i; + EMACS_INT i; for (i = get_free_list_index (needed_pages); i < N_FREE_PAGE_LISTS; i++) if ((ph = find_free_page_first_fit (needed_pages, PLH_FIRST (FREE_HEAP_PAGES (i)))) != 0) ＠＠ -1396,15 +1373,15 ＠＠ allocate_page_from_free_list (EMACS_INT /* Allocates a new page, either from free list or by expanding the heap. */ static page_header * -allocate_new_page (page_list_header *plh, size_t size, int managed) +allocate_new_page (page_list_header *plh, size_t size, EMACS_INT elemcount) { - EMACS_INT needed_pages = BYTES_TO_PAGES (size); + EMACS_INT needed_pages = BYTES_TO_PAGES (size * elemcount); /* first check free list */ page_header *result = allocate_page_from_free_list (needed_pages); if (!result) /* expand heap */ result = expand_heap (needed_pages); - install_page_in_used_list (result, plh, size, managed); + install_page_in_used_list (result, plh, size, elemcount); return result; } ＠＠ -1412,63 +1389,56 ＠＠ allocate_new_page (page_list_header *plh /* Selects the correct size class, tries to allocate a cell of this size from the free list, if this fails, a new page is allocated. */ static void * -mc_alloc_1 (size_t size, int managed) +mc_alloc_1 (size_t size, EMACS_INT elemcount) { page_list_header *plh = 0; page_header *ph = 0; void *result = 0; - if (managed) - plh = USED_HEAP_PAGES (get_used_list_index (size)); - else - plh = UNMANAGED_HEAP_PAGES (get_unmanaged_list_index (size)); + plh = USED_HEAP_PAGES (get_used_list_index (size)); if (size == 0) return 0; - if (size < PAGE_SIZE_DIV_2) + if ((elemcount == 1) && (size < (size_t) PAGE_SIZE_DIV_2)) /* first check any free cells */ ph = allocate_cell (plh); if (!ph) /* allocate a new page */ - ph = allocate_new_page (plh, size, managed); + ph = allocate_new_page (plh, size, elemcount); /* return first element of free list and remove it from the list */ result = (void*) PH_FREE_LIST (ph); PH_FREE_LIST (ph) = NEXT_FREE (PH_FREE_LIST (ph)); - memset (result, '\0', size); - if (managed) - MARK_LRECORD_AS_FREE (result); + memset (result, '\0', (size * elemcount)); + MARK_LRECORD_AS_FREE (result); /* bump used cells counter */ - PH_CELLS_USED (ph)++; + PH_CELLS_USED (ph) += elemcount; #ifdef MEMORY_USAGE_STATS - PLH_USED_CELLS (plh)++; - if (managed) - PLH_USED_SPACE (plh) += size; - else - PLH_USED_SPACE (plh) += PLH_SIZE (plh); + PLH_USED_CELLS (plh) += elemcount; + PLH_USED_SPACE (plh) += size * elemcount; #endif return result; } +/* Array allocation. */ void * -mc_alloc (size_t size) +mc_alloc_array (size_t size, EMACS_INT elemcount) { - return mc_alloc_1 (size, 1); + return mc_alloc_1 (size, elemcount); } void * -mc_alloc_unmanaged (size_t size) +mc_alloc (size_t size) { - return mc_alloc_1 (size, 0); + return mc_alloc_1 (size, 1); } -  /*--- sweep & free & finalize-------------------------------------------*/ ＠＠ -1512,7 +1482,11 ＠＠ mark_free_list (page_header *ph) free_link *fl = PH_FREE_LIST (ph); while (fl) { +#ifdef NEW_GC + SET_BIT (ph, get_mark_bit_index (fl, ph), BLACK); +#else /* not NEW_GC */ SET_BIT (ph, get_mark_bit_index (fl, ph), 1); +#endif /* not NEW_GC */ fl = NEXT_FREE (fl); } } ＠＠ -1529,14 +1503,31 ＠＠ finalize_page (page_header *ph) EMACS_INT heap_space_step = PH_CELL_SIZE (ph); EMACS_INT mark_bit = 0; EMACS_INT mark_bit_max_index = PH_CELLS_ON_PAGE (ph); - int bit = 0; + unsigned int bit = 0; mark_free_list (ph); +#ifdef NEW_GC + /* ARRAY_BIT_HACK */ + if (PH_ARRAY_BIT (ph)) + for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) + { + GET_BIT (bit, ph, mark_bit * N_MARK_BITS); + if (bit) + { + return; + } + } +#endif /* NEW_GC */ + for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) { - GET_BIT (bit, ph, mark_bit); - if (!bit) + GET_BIT (bit, ph, mark_bit * N_MARK_BITS); +#ifdef NEW_GC + if (bit == WHITE) +#else /* not NEW_GC */ + if (bit == 0) +#endif /* not NEW_GC */ { EMACS_INT ptr = (heap_space + (heap_space_step * mark_bit)); MC_ALLOC_CALL_FINALIZER ((void *) ptr); ＠＠ -1559,8 +1550,6 ＠＠ finalize_page_for_disksave (page_header EMACS_INT mark_bit = 0; EMACS_INT mark_bit_max_index = PH_CELLS_ON_PAGE (ph); - mark_free_list (ph); - for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) { EMACS_INT ptr = (heap_space + (heap_space_step * mark_bit)); ＠＠ -1591,23 +1580,46 ＠＠ mc_finalize_for_disksave (void) static void sweep_page (page_header *ph) { - char *heap_space = (char *) PH_HEAP_SPACE (ph); + Rawbyte *heap_space = (Rawbyte *) PH_HEAP_SPACE (ph); EMACS_INT heap_space_step = PH_CELL_SIZE (ph); EMACS_INT mark_bit = 0; EMACS_INT mark_bit_max_index = PH_CELLS_ON_PAGE (ph); - int bit = 0; + unsigned int bit = 0; mark_free_list (ph); +#ifdef NEW_GC + /* ARRAY_BIT_HACK */ + if (PH_ARRAY_BIT (ph)) + for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) + { + GET_BIT (bit, ph, mark_bit * N_MARK_BITS); + if (bit) + { + zero_mark_bits (ph); + PH_BLACK_BIT (ph) = 0; + return; + } + } +#endif /* NEW_GC */ + for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) { - GET_BIT (bit, ph, mark_bit); - if (!bit) + GET_BIT (bit, ph, mark_bit * N_MARK_BITS); +#ifdef NEW_GC + if (bit == WHITE) +#else /* not NEW_GC */ + if (bit == 0) +#endif /* not NEW_GC */ { +#ifdef NEW_GC + GC_STAT_FREED; +#endif /* NEW_GC */ remove_cell (heap_space + (heap_space_step * mark_bit), ph); } } zero_mark_bits (ph); + PH_BLACK_BIT (ph) = 0; if (PH_CELLS_USED (ph) == 0) remove_page_from_used_list (ph); else if (PH_CELLS_USED (ph) < PH_CELLS_ON_PAGE (ph)) ＠＠ -1627,9 +1639,24 ＠＠ mc_sweep (void) void mc_free (void *ptr) { - page_header *ph = get_page_header (ptr); - assert (!PH_ON_FREE_LIST_P (ph)); + page_header *ph; + +#ifdef NEW_GC + /* Do not allow manual freeing while a gc is running. Data is going + to be freed next gc cycle. */ + if (write_barrier_enabled || gc_in_progress) + return; +#endif /* NEW_GC */ + + ph = get_page_header (ptr); + assert (ph); + assert (PH_PLH (ph)); + assert (PLH_LIST_TYPE (PH_PLH (ph)) != FREE_LIST); +#ifdef NEW_GC + if (PH_ON_USED_LIST_P (ph)) + SET_BIT (ph, get_mark_bit_index (ptr, ph), WHITE); +#endif /* NEW_GC */ remove_cell (ptr, ph); if (PH_CELLS_USED (ph) == 0) ＠＠ -1642,29 +1669,32 ＠＠ mc_free (void *ptr) /* Changes the size of the cell pointed to by ptr. Returns the new address of the new cell with new size. */ void * -mc_realloc_1 (void *ptr, size_t size, int managed) +mc_realloc_1 (void *ptr, size_t size, int elemcount) { if (ptr) { - if (size) + if (size * elemcount) { - void *result = mc_alloc_1 (size, managed); + void *result = mc_alloc_1 (size, elemcount); size_t from_size = PH_CELL_SIZE (get_page_header (ptr)); - size_t cpy_size = size; - if (size > from_size) + size_t cpy_size = size * elemcount; + if (cpy_size > from_size) cpy_size = from_size; memcpy (result, ptr, cpy_size); - mc_free (ptr); +#ifdef ALLOC_TYPE_STATS + inc_lrecord_stats (size, (struct lrecord_header *) result); +#endif /* not ALLOC_TYPE_STATS */ + /* mc_free (ptr); not needed, will be collected next gc */ return result; } else { - mc_free (ptr); + /* mc_free (ptr); not needed, will be collected next gc */ return 0; } } else - return mc_alloc_1 (size, managed); + return mc_alloc_1 (size, elemcount); } void * ＠＠ -1674,13 +1704,12 ＠＠ mc_realloc (void *ptr, size_t size) } void * -mc_realloc_unmanaged (void *ptr, size_t size) +mc_realloc_array (void *ptr, size_t size, EMACS_INT elemcount) { - return mc_realloc_1 (ptr, size, 0); + return mc_realloc_1 (ptr, size, elemcount); } -  /*--- initialization ---------------------------------------------------*/ ＠＠ -1688,32 +1717,49 ＠＠ mc_realloc_unmanaged (void *ptr, size_t void init_mc_allocator (void) { - int i; + EMACS_INT i; - memset (&mc_allocator_globals, '\0', sizeof (mc_allocator_globals_type)); +#ifdef MEMORY_USAGE_STATS + MC_MALLOCED_BYTES = 0; +#endif - for (i = 0; i < N_USED_PAGE_LISTS; i++) + /* init of pagesize dependent values */ + switch (SYS_PAGE_SIZE) { - page_list_header *plh = USED_HEAP_PAGES (i); - PLH_LIST_TYPE (plh) = USED_LIST; - PLH_SIZE (plh) = get_used_list_size_value (i); - PLH_FIRST (plh) = 0; - PLH_LAST (plh) = 0; - PLH_MARK_BIT_FREE_LIST (plh) = 0; + case 512: log_page_size = 9; break; + case 1024: log_page_size = 10; break; + case 2048: log_page_size = 11; break; + case 4096: log_page_size = 12; break; + case 8192: log_page_size = 13; break; + case 16384: log_page_size = 14; break; + default: ABORT (); + } + + page_size_div_2 = (EMACS_INT) SYS_PAGE_SIZE >> 1; + + mc_allocator_globals.used_heap_pages = + (page_list_header *) xmalloc_and_zero ((N_USED_PAGE_LISTS + 1) + * sizeof (page_list_header)); #ifdef MEMORY_USAGE_STATS - PLH_PAGE_COUNT (plh) = 0; - PLH_USED_CELLS (plh) = 0; - PLH_USED_SPACE (plh) = 0; - PLH_TOTAL_CELLS (plh) = 0; - PLH_TOTAL_SPACE (plh) = 0; + MC_MALLOCED_BYTES += (N_USED_PAGE_LISTS + 1) * sizeof (page_list_header); #endif - } + + mc_allocator_globals.ptr_lookup_table = + (level_2_lookup_tree **) + xmalloc_and_zero ((LEVEL1_SIZE + 1) * sizeof (level_2_lookup_tree *)); +#ifdef MEMORY_USAGE_STATS + MC_MALLOCED_BYTES += (LEVEL1_SIZE + 1) * sizeof (level_2_lookup_tree *); +#endif + +#ifdef BLOCKTYPE_ALLOC_PAGE_HEADER + the_page_header_blocktype = Blocktype_new (struct page_header_blocktype); +#endif /* BLOCKTYPE_ALLOC_PAGE_HEADER */ - for (i = 0; i < N_UNMANAGED_PAGE_LISTS; i++) + for (i = 0; i < N_USED_PAGE_LISTS; i++) { - page_list_header *plh = UNMANAGED_HEAP_PAGES (i); - PLH_LIST_TYPE (plh) = UNMANAGED_LIST; - PLH_SIZE (plh) = get_unmanaged_list_size_value (i); + page_list_header *plh = USED_HEAP_PAGES (i); + PLH_LIST_TYPE (plh) = USED_LIST; + PLH_SIZE (plh) = get_used_list_size_value (i); PLH_FIRST (plh) = 0; PLH_LAST (plh) = 0; PLH_MARK_BIT_FREE_LIST (plh) = 0; ＠＠ -1743,10 +1789,12 ＠＠ init_mc_allocator (void) #endif } +#ifndef BLOCKTYPE_ALLOC_PAGE_HEADER PAGE_HEADER_FREE_LIST = 0; +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ #ifdef MEMORY_USAGE_STATS - MC_MALLOCED_BYTES = sizeof (mc_allocator_globals); + MC_MALLOCED_BYTES += sizeof (mc_allocator_globals); #endif init_lookup_table (); ＠＠ -1765,12 +1813,11 ＠＠ Returns stats about the mc-alloc memory { Lisp_Object free_plhs = Qnil; Lisp_Object used_plhs = Qnil; - Lisp_Object unmanaged_plhs = Qnil; Lisp_Object heap_sects = Qnil; - int used_size = 0; - int real_size = 0; + EMACS_INT used_size = 0; + EMACS_INT real_size = 0; - int i; + EMACS_INT i; for (i = 0; i < N_FREE_PAGE_LISTS; i++) if (PLH_PAGE_COUNT (FREE_HEAP_PAGES(i)) > 0) ＠＠ -1779,17 +1826,6 ＠＠ Returns stats about the mc-alloc memory list1 (make_int (PLH_PAGE_COUNT (FREE_HEAP_PAGES(i)))), free_plhs); - for (i = 0; i < N_UNMANAGED_PAGE_LISTS; i++) - if (PLH_PAGE_COUNT (UNMANAGED_HEAP_PAGES(i)) > 0) - unmanaged_plhs = - acons (make_int (PLH_SIZE (UNMANAGED_HEAP_PAGES(i))), - list5 (make_int (PLH_PAGE_COUNT (UNMANAGED_HEAP_PAGES(i))), - make_int (PLH_USED_CELLS (UNMANAGED_HEAP_PAGES(i))), - make_int (PLH_USED_SPACE (UNMANAGED_HEAP_PAGES(i))), - make_int (PLH_TOTAL_CELLS (UNMANAGED_HEAP_PAGES(i))), - make_int (PLH_TOTAL_SPACE (UNMANAGED_HEAP_PAGES(i)))), - unmanaged_plhs); - for (i = 0; i < N_USED_PAGE_LISTS; i++) if (PLH_PAGE_COUNT (USED_HEAP_PAGES(i)) > 0) used_plhs = ＠＠ -1813,9 +1849,8 ＠＠ Returns stats about the mc-alloc memory make_int (real_size)); return Fcons (make_int (PAGE_SIZE), - list6 (heap_sects, + list5 (heap_sects, Fnreverse (used_plhs), - Fnreverse (unmanaged_plhs), Fnreverse (free_plhs), make_int (sizeof (mc_allocator_globals)), make_int (MC_MALLOCED_BYTES))); ＠＠ -1829,3 +1864,198 ＠＠ syms_of_mc_alloc (void) DEFSUBR (Fmc_alloc_memory_usage); #endif /* MEMORY_USAGE_STATS */ } + + +#ifdef NEW_GC +/*--- incremental garbage collector ----------------------------------*/ + +/* access dirty bit of page header */ +void +set_dirty_bit (page_header *ph, unsigned int value) +{ + PH_DIRTY_BIT (ph) = value; +} + +void +set_dirty_bit_for_address (void *ptr, unsigned int value) +{ + set_dirty_bit (get_page_header (ptr), value); +} + +unsigned int +get_dirty_bit (page_header *ph) +{ + return PH_DIRTY_BIT (ph); +} + +unsigned int +get_dirty_bit_for_address (void *ptr) +{ + return get_dirty_bit (get_page_header (ptr)); +} + + +/* access protection bit of page header */ +void +set_protection_bit (page_header *ph, unsigned int value) +{ + PH_PROTECTION_BIT (ph) = value; +} + +void +set_protection_bit_for_address (void *ptr, unsigned int value) +{ + set_protection_bit (get_page_header (ptr), value); +} + +unsigned int +get_protection_bit (page_header *ph) +{ + return PH_PROTECTION_BIT (ph); +} + +unsigned int +get_protection_bit_for_address (void *ptr) +{ + return get_protection_bit (get_page_header (ptr)); +} + + +/* Returns the start of the page of the object pointed to by ptr. */ +void * +get_page_start (void *ptr) +{ + return PH_HEAP_SPACE (get_page_header (ptr)); +} + +/* Make PAGE_SIZE globally available. */ +EMACS_INT +mc_get_page_size () +{ + return PAGE_SIZE; +} + +/* Is the fault at ptr on a protected page? */ +EMACS_INT +fault_on_protected_page (void *ptr) +{ + page_header *ph = get_page_header_internal (ptr); + return (ph + && PH_HEAP_SPACE (ph) + && (PH_HEAP_SPACE (ph) <= ptr) + && ((void *) ((EMACS_INT) PH_HEAP_SPACE (ph) + + PH_N_PAGES (ph) * PAGE_SIZE) > ptr) + && (PH_PROTECTION_BIT (ph) == 1)); +} + + +/* Protect the heap page of given page header ph if black objects are + on the page. */ +static void +protect_heap_page (page_header *ph) +{ + if (PH_BLACK_BIT (ph)) + { + void *heap_space = PH_HEAP_SPACE (ph); + EMACS_INT heap_space_size = PH_N_PAGES (ph) * PAGE_SIZE; + vdb_protect ((void *) heap_space, heap_space_size); + PH_PROTECTION_BIT (ph) = 1; + } +} + +/* Protect all heap pages with black objects. */ +void +protect_heap_pages (void) +{ + visit_all_used_page_headers (protect_heap_page); +} + + +/* Remove protection (if there) of heap page of given page header + ph. */ +static void +unprotect_heap_page (page_header *ph) +{ + if (PH_PROTECTION_BIT (ph)) + { + void *heap_space = PH_HEAP_SPACE (ph); + EMACS_INT heap_space_size = PH_N_PAGES (ph) * PAGE_SIZE; + vdb_unprotect (heap_space, heap_space_size); + PH_PROTECTION_BIT (ph) = 0; + } +} + +/* Remove protection for all heap pages which are protected. */ +void +unprotect_heap_pages (void) +{ + visit_all_used_page_headers (unprotect_heap_page); +} + +/* Remove protection and mark page dirty. */ +void +unprotect_page_and_mark_dirty (void *ptr) +{ + page_header *ph = get_page_header (ptr); + unprotect_heap_page (ph); + PH_DIRTY_BIT (ph) = 1; +} + +/* Repush all objects on dirty pages onto the mark stack. */ +int +repush_all_objects_on_page (void *ptr) +{ + int repushed_objects = 0; + page_header *ph = get_page_header (ptr); + Rawbyte *heap_space = (Rawbyte *) PH_HEAP_SPACE (ph); + EMACS_INT heap_space_step = PH_CELL_SIZE (ph); + EMACS_INT mark_bit = 0; + EMACS_INT mark_bit_max_index = PH_CELLS_ON_PAGE (ph); + unsigned int bit = 0; + for (mark_bit = 0; mark_bit < mark_bit_max_index; mark_bit++) + { + GET_BIT (bit, ph, mark_bit * N_MARK_BITS); + if (bit == BLACK) + { + repushed_objects++; + gc_write_barrier + (wrap_pointer_1 ((heap_space + (heap_space_step * mark_bit)))); + } + } + PH_BLACK_BIT (ph) = 0; + PH_DIRTY_BIT (ph) = 0; + return repushed_objects; +} + +/* Mark black if object is currently grey. This first checks, if the + object is really allocated on the mc-heap. If it is, it can be + marked black; if it is not, it cannot be marked. */ +EMACS_INT +maybe_mark_black (void *ptr) +{ + page_header *ph = get_page_header_internal (ptr); + unsigned int bit = 0; + + if (ph && PH_PLH (ph) && PH_ON_USED_LIST_P (ph)) + { + GET_BIT (bit, ph, get_mark_bit_index (ptr, ph)); + if (bit == GREY) + { + if (!PH_BLACK_BIT (ph)) + PH_BLACK_BIT (ph) = 1; + SET_BIT (ph, get_mark_bit_index (ptr, ph), BLACK); + } + return 1; + } + return 0; +} + +/* Only for debugging --- not used anywhere in the sources. */ +EMACS_INT +object_on_heap_p (void *ptr) +{ + page_header *ph = get_page_header_internal (ptr); + return (ph && PH_ON_USED_LIST_P (ph)); +} + +#endif /* NEW_GC */ 1.3 +98 -32 XEmacs/xemacs/src/mc-alloc.h Index: mc-alloc.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/mc-alloc.h,v retrieving revision 1.2 retrieving revision 1.3 diff -u -p -r1.2 -r1.3 --- mc-alloc.h 2005/10/14 01:22:01 1.2 +++ mc-alloc.h 2005/11/25 01:42:05 1.3 ＠＠ -23,43 +23,87 ＠＠ Boston, MA 02111-1307, USA. */ #ifndef INCLUDED_mc_alloc_h_ #define INCLUDED_mc_alloc_h_ - -/* This is moved here from alloc.c. */ -#ifndef MALLOC_OVERHEAD -# ifdef GNU_MALLOC -# define MALLOC_OVERHEAD 0 -# elif defined (rcheck) -# define MALLOC_OVERHEAD 20 -# else -# define MALLOC_OVERHEAD 8 -# endif -#endif /* MALLOC_OVERHEAD */ - /*--- prototypes -------------------------------------------------------*/ BEGIN_C_DECLS -/* Allocation related functions and macros: */ +/* Internal Allocator Functions: */ -/* Builds and initializes all needed datastructures of the new allocator. */ +/* Initialize the allocator. This has to be called prior to + requesting memory. */ void init_mc_allocator (void); -/* Returns a pointer to a block of memory of given size on the used heap. */ +/* Allocate a block of memory of given size and return the pointer to + it. */ void *mc_alloc (size_t size); -/* Frees the object pointed to by pointer. */ +/* Allocate a block of memory as an array with elemcount elements of + given size and return the pointer to it. Arrays contain several + objects that are allocated in one consecutive block of memory with + each element being a fully qualified object---that is, it has a + Lisp object header and a mark bit. Objects like hash tables and + dynamic arrays use this function. */ +void *mc_alloc_array (size_t size, EMACS_INT elemcount); + +/* Free the object pointed to by ptr and make its memory re-usable + again. The memory must have been returned by a previous call to + mc_alloc(). This can be used to free memory explicitly, outside a + garbage collection. */ void mc_free (void *ptr); -/* Modifies the size of the memory block pointed to by ptr. The - Address of the new block of given size is returned. */ +/* Modify the size of the memory block pointed to by ptr. Return the + address of the new block of given size. The content of the memory + block will be unchanged to the minimum of the old and new sizes: if + the new size is smaller, the overlaying data is cut off; if the new + size is bigger, the newly allocated memory will be uninitialized.*/ void *mc_realloc (void *ptr, size_t size); +/* Modify the size of the array pointed to by ptr. Return the address + of the new array block with elemcount elements of given size. The + content of the memory block will be unchanged to the minimum of the + old and new sizes: if the new size is smaller, the overlaying data + is cut off; if the new size is bigger, the newly allocated memory + will be uninitialized.*/ +void *mc_realloc_array (void *ptr, size_t size, EMACS_INT elemcount); + /* Garbage collection related functions and macros: */ +#ifdef NEW_GC +enum mark_bit_colors +{ + WHITE = 0, + BLACK = 1, + GREY = 2 +}; + +/* Set the mark bit of the object pointed to by ptr to value.*/ +void set_mark_bit (void *ptr, EMACS_INT value); + +/* Return the mark bit of the object pointed to by ptr. */ +EMACS_INT get_mark_bit (void *ptr); + +/* mark bit macros */ +/* Returns true if the mark bit of the object pointed to by ptr is set. */ +#define MARKED_P(ptr) (get_mark_bit (ptr) != WHITE) + +/* Marks the object pointed to by ptr (sets the mark bit to 1). */ +#define MARK(ptr) set_mark_bit (ptr, BLACK) + +/* Unmarks the object pointed to by ptr (sets the mark bit to 0). */ +#define UNMARK(ptr) set_mark_bit (ptr, WHITE) + +#define MARK_WHITE(ptr) set_mark_bit (ptr, WHITE) +#define MARK_GREY(ptr) set_mark_bit (ptr, GREY) +#define MARK_BLACK(ptr) set_mark_bit (ptr, BLACK) + +#define MARKED_WHITE_P(ptr) (get_mark_bit (ptr) == WHITE) +#define MARKED_GREY_P(ptr) (get_mark_bit (ptr) == GREY) +#define MARKED_BLACK_P(ptr) (get_mark_bit (ptr) == BLACK) +#else /* not NEW_GC */ /* Set the mark bit of the object pointed to by ptr to value.*/ void set_mark_bit (void *ptr, EMACS_INT value); ＠＠ -75,8 +119,9 ＠＠ EMACS_INT get_mark_bit (void *ptr); /* Unmarks the object pointed to by ptr (sets the mark bit to 0). */ #define UNMARK(ptr) set_mark_bit (ptr, 0) +#endif /* not NEW_GC */ -/* The finalizer of every not marked object is called. The macro +/* The finalizer of every not marked object is called. The macro MC_ALLOC_CALL_FINALIZER has to be defined and call the finalizer of the object. */ void mc_finalize (void); ＠＠ -89,24 +134,12 ＠＠ void mc_sweep (void); /* Portable dumper related functions and macros: */ /* The finalizer for disksave of every object is called to shrink the - dump image. The macro MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE has to + dump image. The macro MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE has to be defined and call the finalizer for disksave of the object. */ void mc_finalize_for_disksave (void); -/* Allocation function for the unmanaged heap: */ - -/* Returns a pointer to a block of memory of given size on the - unmanaged heap. */ -void *mc_alloc_unmanaged (size_t size); - -/* Modifies the size of the memory block pointed to by ptr. The - Address of the new block of given size is returned. */ -void *mc_realloc_unmanaged (void *ptr, size_t size); - - - /* Functions and macros related with allocation statistics: */ #ifdef MEMORY_USAGE_STATS ＠＠ -115,6 +148,39 ＠＠ void *mc_realloc_unmanaged (void *ptr, s Bytecount mc_alloced_storage_size (Bytecount claimed_size, struct overhead_stats *stats); #endif /* MEMORY_USAGE_STATS */ + + +#ifdef NEW_GC +/* Incremental Garbage Collector / Write Barrier Support: */ + +/* Return the PAGESIZE the allocator uses. Generally equals to the + system's PAGESIZE. */ +EMACS_INT mc_get_page_size (void); + +/* Is the fault at ptr on a protected page? */ +EMACS_INT fault_on_protected_page (void *ptr); + +/* Remove protection (if there) of heap page of given page header + ph. */ +void protect_heap_pages (void); + +/* Remove protection for all heap pages which are protected. */ +void unprotect_heap_pages (void); + +/* Remove protection and mark page dirty. */ +void unprotect_page_and_mark_dirty (void *ptr); + +/* Repush all objects on dirty pages onto the mark stack. Return + number of repushed objects. */ +int repush_all_objects_on_page (void *ptr); + +/* Mark black if object is currently grey. */ +EMACS_INT maybe_mark_black (void *ptr); + +/* Only for debugging---not used anywhere in the sources. */ +EMACS_INT object_on_heap_p (void *ptr); + +#endif /* NEW_GC */ END_C_DECLS 1.2 +32 -0 XEmacs/xemacs/src/objects-tty-impl.h Index: objects-tty-impl.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-tty-impl.h,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- objects-tty-impl.h 2002/06/20 21:18:39 1.1 +++ objects-tty-impl.h 2005/11/25 01:42:05 1.2 ＠＠ -29,9 +29,25 ＠＠ Boston, MA 02111-1307, USA. */ struct tty_color_instance_data { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Lisp_Object symbol; /* so we don't have to constantly call Fintern() */ }; +#ifdef NEW_GC +DECLARE_LRECORD (tty_color_instance_data, struct tty_color_instance_data); +#define XTTY_COLOR_INSTANCE_DATA(x) \ + XRECORD (x, tty_color_instance_data, struct tty_color_instance_data) +#define wrap_tty_color_instance_data(p) \ + wrap_record (p, tty_color_instance_data) +#define TTY_COLOR_INSTANCE_DATAP(x) RECORDP (x, tty_color_instance_data) +#define CHECK_TTY_COLOR_INSTANCE_DATA(x) \ + CHECK_RECORD (x, tty_color_instance_data) +#define CONCHECK_TTY_COLOR_INSTANCE_DATA(x) \ + CONCHECK_RECORD (x, tty_color_instance_data) +#endif /* NEW_GC */ + #define TTY_COLOR_INSTANCE_DATA(c) \ ((struct tty_color_instance_data *) (c)->data) ＠＠ -39,8 +55,24 ＠＠ struct tty_color_instance_data struct tty_font_instance_data { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Lisp_Object charset; }; + +#ifdef NEW_GC +DECLARE_LRECORD (tty_font_instance_data, struct tty_font_instance_data); +#define XTTY_FONT_INSTANCE_DATA(x) \ + XRECORD (x, tty_font_instance_data, struct tty_font_instance_data) +#define wrap_tty_font_instance_data(p) \ + wrap_record (p, tty_font_instance_data) +#define TTY_FONT_INSTANCE_DATAP(x) RECORDP (x, tty_font_instance_data) +#define CHECK_TTY_FONT_INSTANCE_DATA(x) \ + CHECK_RECORD (x, tty_font_instance_data) +#define CONCHECK_TTY_FONT_INSTANCE_DATA(x) \ + CONCHECK_RECORD (x, tty_font_instance_data) +#endif /* NEW_GC */ #define TTY_FONT_INSTANCE_DATA(c) \ ((struct tty_font_instance_data *) (c)->data) 1.17 +41 -0 XEmacs/xemacs/src/objects-tty.c Index: objects-tty.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects-tty.c,v retrieving revision 1.16 retrieving revision 1.17 diff -u -p -r1.16 -r1.17 --- objects-tty.c 2005/01/28 02:58:51 1.16 +++ objects-tty.c 2005/11/25 01:42:06 1.17 ＠＠ -42,18 +42,36 ＠＠ static const struct memory_description t { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("tty-color-instance-data", + tty_color_instance_data, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + tty_color_instance_data_description_1, + struct tty_color_instance_data); +#else /* not NEW_GC */ const struct sized_memory_description tty_color_instance_data_description = { sizeof (struct tty_color_instance_data), tty_color_instance_data_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description tty_font_instance_data_description_1 [] = { { XD_LISP_OBJECT, offsetof (struct tty_font_instance_data, charset) }, { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("tty-font-instance-data", + tty_font_instance_data, + 0, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + tty_font_instance_data_description_1, + struct tty_font_instance_data); +#else /* not NEW_GC */ const struct sized_memory_description tty_font_instance_data_description = { sizeof (struct tty_font_instance_data), tty_font_instance_data_description_1 }; +#endif /* not NEW_GC */ DEFUN ("register-tty-color", Fregister_tty_color, 3, 3, 0, /* Register COLOR as a recognized TTY color. ＠＠ -176,7 +194,12 ＠＠ tty_initialize_color_instance (Lisp_Colo } /* Don't allocate the data until we're sure that we will succeed. */ +#ifdef NEW_GC + c->data = alloc_lrecord_type (struct tty_color_instance_data, + &lrecord_tty_color_instance_data); +#else /* not NEW_GC */ c->data = xnew (struct tty_color_instance_data); +#endif /* not NEW_GC */ COLOR_INSTANCE_TTY_SYMBOL (c) = name; return 1; ＠＠ -199,7 +222,11 ＠＠ static void tty_finalize_color_instance (Lisp_Color_Instance *c) { if (c->data) +#ifdef NEW_GC + mc_free (c->data); +#else /* not NEW_GC */ xfree (c->data, void *); +#endif /* not NEW_GC */ } static int ＠＠ -254,7 +281,12 ＠＠ tty_initialize_font_instance (Lisp_Font_ } /* Don't allocate the data until we're sure that we will succeed. */ +#ifdef NEW_GC + f->data = alloc_lrecord_type (struct tty_font_instance_data, + &lrecord_tty_font_instance_data); +#else /* not NEW_GC */ f->data = xnew (struct tty_font_instance_data); +#endif /* not NEW_GC */ FONT_INSTANCE_TTY_CHARSET (f) = charset; #ifdef MULE if (CHARSETP (charset)) ＠＠ -287,7 +319,11 ＠＠ static void tty_finalize_font_instance (Lisp_Font_Instance *f) { if (f->data) +#ifdef NEW_GC + mc_free (f->data); +#else /* not NEW_GC */ xfree (f->data, void *); +#endif /* not NEW_GC */ } static Lisp_Object ＠＠ -363,6 +399,11 ＠＠ tty_find_charset_font (Lisp_Object devic void syms_of_objects_tty (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (tty_color_instance_data); + INIT_LRECORD_IMPLEMENTATION (tty_font_instance_data); +#endif /* NEW_GC */ + DEFSUBR (Fregister_tty_color); DEFSUBR (Funregister_tty_color); DEFSUBR (Ffind_tty_color); 1.30 +9 -1 XEmacs/xemacs/src/objects.c Index: objects.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/objects.c,v retrieving revision 1.29 retrieving revision 1.30 diff -u -p -r1.29 -r1.30 --- objects.c 2005/10/24 10:07:39 1.29 +++ objects.c 2005/11/25 01:42:06 1.30 ＠＠ -63,7 +63,11 ＠＠ Lisp_Object Qcolor_instancep; static const struct memory_description color_instance_data_description_1 []= { #ifdef HAVE_TTY +#ifdef NEW_GC + { XD_LISP_OBJECT, tty_console }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, tty_console, 1, { &tty_color_instance_data_description } }, +#endif /* not NEW_GC */ #endif { XD_END } }; ＠＠ -272,7 +276,11 ＠＠ static Lisp_Object font_instance_truenam static const struct memory_description font_instance_data_description_1 []= { #ifdef HAVE_TTY - { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description} }, +#ifdef NEW_GC + { XD_LISP_OBJECT, tty_console }, +#else /* not NEW_GC */ + { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description } }, +#endif /* not NEW_GC */ #endif { XD_END } }; 1.59 +15 -3 XEmacs/xemacs/src/print.c Index: print.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/print.c,v retrieving revision 1.58 retrieving revision 1.59 diff -u -p -r1.58 -r1.59 --- print.c 2005/11/22 09:02:43 1.58 +++ print.c 2005/11/25 01:42:06 1.59 ＠＠ -1733,6 +1733,17 ＠＠ print_internal (Lisp_Object obj, Lisp_Ob if (STRINGP (obj)) { +#ifdef NEW_GC + if (!debug_can_access_memory (XSTRING_DATA (obj), + XSTRING_LENGTH (obj))) + { + write_fmt_string + (printcharfun, + "#<EMACS BUG: %p (BAD STRING DATA %p)>", + lheader, XSTRING_DATA (obj)); + break; + } +#else /* not NEW_GC */ Lisp_String *l = (Lisp_String *) lheader; if (!debug_can_access_memory (l->data_, l->size_)) { ＠＠ -1742,6 +1753,7 ＠＠ print_internal (Lisp_Object obj, Lisp_Ob lheader, l->data_); break; } +#endif /* not NEW_GC */ } } ＠＠ -2219,9 +2231,9 ＠＠ debug_p4 (Lisp_Object obj) debug_out ("#<%s addr=0x%lx uid=0x%lx>", LHEADER_IMPLEMENTATION (header)->name, (EMACS_INT) header, - LHEADER_IMPLEMENTATION (header)->basic_p ? - ((struct lrecord_header *) header)->uid : - ((struct old_lcrecord_header *) header)->uid); + (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? + ((struct lrecord_header *) header)->uid : + ((struct old_lcrecord_header *) header)->uid)); #endif /* not MC_ALLOC */ } 1.43 +25 -0 XEmacs/xemacs/src/specifier.c Index: specifier.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.c,v retrieving revision 1.42 retrieving revision 1.43 diff -u -p -r1.42 -r1.43 --- specifier.c 2005/10/24 10:07:40 1.42 +++ specifier.c 2005/11/25 01:42:06 1.43 ＠＠ -302,7 +302,11 ＠＠ finalize_specifier (void *header, int fo /* don't be snafued by the disksave finalization. */ if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching) { +#ifdef NEW_GC + mc_free (sp->caching); +#else /* not NEW_GC */ xfree (sp->caching, struct specifier_caching *); +#endif /* not NEW_GC */ sp->caching = 0; } } ＠＠ -382,10 +386,19 ＠＠ static const struct memory_description s { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("specifier-caching", + specifier_caching, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + specifier_caching_description_1, + struct specifier_caching); +#else /* not NEW_GC */ static const struct sized_memory_description specifier_caching_description = { sizeof (struct specifier_caching), specifier_caching_description_1 }; +#endif /* not NEW_GC */ static const struct sized_memory_description specifier_extra_description_map[] = { ＠＠ -403,8 +416,12 ＠＠ const struct memory_description specifie { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) }, +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Lisp_Specifier, caching) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (Lisp_Specifier, caching), 1, { &specifier_caching_description } }, +#endif /* not NEW_GC */ { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) }, { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) }, { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1, ＠＠ -2996,7 +3013,12 ＠＠ set_specifier_caching (Lisp_Object speci assert (!GHOST_SPECIFIER_P (sp)); if (!sp->caching) +#ifdef NEW_GC + sp->caching = alloc_lrecord_type (struct specifier_caching, + &lrecord_specifier_caching); +#else /* not NEW_GC */ sp->caching = xnew_and_zero (struct specifier_caching); +#endif /* not NEW_GC */ sp->caching->offset_into_struct_window = struct_window_offset; sp->caching->value_changed_in_window = value_changed_in_window; sp->caching->offset_into_struct_frame = struct_frame_offset; ＠＠ -3349,6 +3371,9 ＠＠ void syms_of_specifier (void) { INIT_LRECORD_IMPLEMENTATION (specifier); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (specifier_caching); +#endif /* NEW_GC */ DEFSYMBOL (Qspecifierp); 1.19 +16 -0 XEmacs/xemacs/src/specifier.h Index: specifier.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/specifier.h,v retrieving revision 1.18 retrieving revision 1.19 diff -u -p -r1.18 -r1.19 --- specifier.h 2005/10/24 10:07:41 1.18 +++ specifier.h 2005/11/25 01:42:06 1.19 ＠＠ -423,6 +423,9 ＠＠ enum spec_add_meth struct specifier_caching { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ int offset_into_struct_window; void (*value_changed_in_window) (Lisp_Object specifier, struct window *w, Lisp_Object oldval); ＠＠ -431,6 +434,19 ＠＠ struct specifier_caching Lisp_Object oldval); int always_recompute; }; + +#ifdef NEW_GC +DECLARE_LRECORD (specifier_caching, struct specifier_caching); +#define XSPECIFIER_CACHING(x) \ + XRECORD (x, specifier_caching, struct specifier_caching) +#define wrap_specifier_caching(p) \ + wrap_record (p, specifier_caching) +#define SPECIFIER_CACHINGP(x) RECORDP (x, specifier_caching) +#define CHECK_SPECIFIER_CACHING(x) \ + CHECK_RECORD (x, specifier_caching) +#define CONCHECK_SPECIFIER_CACHING(x) \ + CONCHECK_RECORD (x, specifier_caching) +#endif /* NEW_GC */ /* #### get image instances out of domains! */ 1.25 +21 -0 XEmacs/xemacs/src/syntax.c Index: syntax.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/syntax.c,v retrieving revision 1.24 retrieving revision 1.25 diff -u -p -r1.24 -r1.25 --- syntax.c 2005/10/25 11:16:28 1.24 +++ syntax.c 2005/11/25 01:42:06 1.25 ＠＠ -309,10 +309,19 ＠＠ static const struct memory_description s { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("syntax-cache", syntax_cache, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + syntax_cache_description_1, + Lisp_Syntax_Cache); +#else /* not NEW_GC */ + const struct sized_memory_description syntax_cache_description = { sizeof (struct syntax_cache), syntax_cache_description_1 }; +#endif /* not NEW_GC */ void mark_buffer_syntax_cache (struct buffer *buf) ＠＠ -344,7 +353,12 ＠＠ void init_buffer_syntax_cache (struct buffer *buf) { struct syntax_cache *cache; +#ifdef NEW_GC + buf->syntax_cache = alloc_lrecord_type (struct syntax_cache, + &lrecord_syntax_cache); +#else /* not NEW_GC */ buf->syntax_cache = xnew_and_zero (struct syntax_cache); +#endif /* not NEW_GC */ cache = buf->syntax_cache; cache->object = wrap_buffer (buf); cache->buffer = buf; ＠＠ -359,7 +373,11 ＠＠ init_buffer_syntax_cache (struct buffer void uninit_buffer_syntax_cache (struct buffer *buf) { +#ifdef NEW_GC + mc_free (buf->syntax_cache); +#else /* not NEW_GC */ xfree (buf->syntax_cache, struct syntax_cache *); +#endif /* not NEW_GC */ buf->syntax_cache = 0; } ＠＠ -2313,6 +2331,9 ＠＠ update_syntax_table (Lisp_Object table) void syms_of_syntax (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (syntax_cache); +#endif /* NEW_GC */ DEFSYMBOL (Qsyntax_table_p); DEFSYMBOL (Qsyntax_table); 1.13 +18 -0 XEmacs/xemacs/src/syntax.h Index: syntax.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/syntax.h,v retrieving revision 1.12 retrieving revision 1.13 diff -u -p -r1.12 -r1.13 --- syntax.h 2003/02/20 08:19:43 1.12 +++ syntax.h 2005/11/25 01:42:07 1.13 ＠＠ -295,6 +295,9 ＠＠ extern int lookup_syntax_properties; faster than if we did the whole calculation from scratch. */ struct syntax_cache { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ int use_code; /* Whether to use syntax_code or syntax_table. This is set depending on whether the ＠＠ -332,6 +335,21 ＠＠ struct syntax_cache Charxpos prev_change; /* Position of the previous extent change. */ }; + +#ifdef NEW_GC +typedef struct syntax_cache Lisp_Syntax_Cache; + +DECLARE_LRECORD (syntax_cache, Lisp_Syntax_Cache); + +#define XSYNTAX_CACHE(x) \ + XRECORD (x, syntax_cache, Lisp_Syntax_Cache) +#define wrap_syntax_cache(p) wrap_record (p, syntax_cache) +#define SYNTAX_CACHE_P(x) RECORDP (x, syntax_cache) +#define CHECK_SYNTAX_CACHE(x) CHECK_RECORD (x, syntax_cache) +#define CONCHECK_SYNTAX_CACHE(x) CONCHECK_RECORD (x, syntax_cache) +#endif /* NEW_GC */ + + extern const struct sized_memory_description syntax_cache_description; 1.90 +69 -0 XEmacs/xemacs/src/window.c Index: window.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/window.c,v retrieving revision 1.89 retrieving revision 1.90 diff -u -p -r1.89 -r1.90 --- window.c 2005/11/18 12:23:57 1.89 +++ window.c 2005/11/25 01:42:08 1.90 ＠＠ -181,40 +181,80 ＠＠ static const struct memory_description f { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("face-cachel", face_cachel, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + face_cachel_description_1, + Lisp_Face_Cachel); +#endif /* NEW_GC */ + static const struct sized_memory_description face_cachel_description = { sizeof (face_cachel), face_cachel_description_1 }; static const struct memory_description face_cachel_dynarr_description_1[] = { +#ifdef NEW_GC + XD_LISP_DYNARR_DESC (face_cachel_dynarr, &face_cachel_description), +#else /* not NEW_GC */ XD_DYNARR_DESC (face_cachel_dynarr, &face_cachel_description), +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("face-cachel-dynarr", face_cachel_dynarr, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + face_cachel_dynarr_description_1, + face_cachel_dynarr); +#else /* not NEW_GC */ static const struct sized_memory_description face_cachel_dynarr_description = { sizeof (face_cachel_dynarr), face_cachel_dynarr_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description glyph_cachel_description_1[] = { { XD_LISP_OBJECT, offsetof (glyph_cachel, glyph) }, { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("glyph-cachel", glyph_cachel, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + glyph_cachel_description_1, + Lisp_Glyph_Cachel); +#endif /* NEW_GC */ + static const struct sized_memory_description glyph_cachel_description = { sizeof (glyph_cachel), glyph_cachel_description_1 }; static const struct memory_description glyph_cachel_dynarr_description_1[] = { +#ifdef NEW_GC + XD_LISP_DYNARR_DESC (glyph_cachel_dynarr, &glyph_cachel_description), +#else /* not NEW_GC */ XD_DYNARR_DESC (glyph_cachel_dynarr, &glyph_cachel_description), +#endif /* not NEW_GC */ { XD_END } }; +#ifdef NEW_GC +DEFINE_LRECORD_IMPLEMENTATION ("glyph-cachel-dynarr", glyph_cachel_dynarr, + 1, /*dumpable-flag*/ + 0, 0, 0, 0, 0, + glyph_cachel_dynarr_description_1, + glyph_cachel_dynarr); +#else /* not NEW_GC */ static const struct sized_memory_description glyph_cachel_dynarr_description = { sizeof (glyph_cachel_dynarr), glyph_cachel_dynarr_description_1 }; +#endif /* not NEW_GC */ static const struct memory_description line_start_cache_description_1[] = { { XD_END } ＠＠ -241,10 +281,15 ＠＠ static const struct memory_description w { XD_LISP_OBJECT_ARRAY, offsetof (struct window, slot), size }, #include "winslots.h" +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (struct window, face_cachels) }, + { XD_LISP_OBJECT, offsetof (struct window, glyph_cachels) }, +#else /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (struct window, face_cachels), 1, { &face_cachel_dynarr_description } }, { XD_BLOCK_PTR, offsetof (struct window, glyph_cachels), 1, { &glyph_cachel_dynarr_description } }, +#endif /* not NEW_GC */ { XD_BLOCK_PTR, offsetof (struct window, line_start_cache), 1, { &line_start_cache_dynarr_description }, XD_FLAG_NO_KKCC }, { XD_END } ＠＠ -362,8 +407,17 ＠＠ allocate_window (void) INIT_DISP_VARIABLE (last_point, Fmake_marker ()); INIT_DISP_VARIABLE (last_start, Fmake_marker ()); INIT_DISP_VARIABLE (last_facechange, Qzero); +#ifdef NEW_GC + p->face_cachels = Dynarr_lisp_new (face_cachel, + &lrecord_face_cachel_dynarr, + &lrecord_face_cachel); + p->glyph_cachels = Dynarr_lisp_new (glyph_cachel, + &lrecord_glyph_cachel_dynarr, + &lrecord_glyph_cachel); +#else /* not NEW_GC */ p->face_cachels = Dynarr_new (face_cachel); p->glyph_cachels = Dynarr_new (glyph_cachel); +#endif /* not NEW_GC */ p->line_start_cache = Dynarr_new (line_start_cache); p->subwindow_instance_cache = make_image_instance_cache_hash_table (); ＠＠ -3810,8 +3864,17 ＠＠ make_dummy_parent (Lisp_Object window) /* Don't copy the pointers to the line start cache or the face instances. */ p->line_start_cache = Dynarr_new (line_start_cache); +#ifdef NEW_GC + p->face_cachels = Dynarr_lisp_new (face_cachel, + &lrecord_face_cachel_dynarr, + &lrecord_face_cachel); + p->glyph_cachels = Dynarr_lisp_new (glyph_cachel, + &lrecord_glyph_cachel_dynarr, + &lrecord_glyph_cachel); +#else /* not NEW_GC */ p->face_cachels = Dynarr_new (face_cachel); p->glyph_cachels = Dynarr_new (glyph_cachel); +#endif /* not NEW_GC */ p->subwindow_instance_cache = make_image_instance_cache_hash_table (); ＠＠ -5384,6 +5447,12 ＠＠ syms_of_window (void) { INIT_LRECORD_IMPLEMENTATION (window); INIT_LRECORD_IMPLEMENTATION (window_mirror); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (face_cachel); + INIT_LRECORD_IMPLEMENTATION (face_cachel_dynarr); + INIT_LRECORD_IMPLEMENTATION (glyph_cachel); + INIT_LRECORD_IMPLEMENTATION (glyph_cachel_dynarr); +#endif /* NEW_GC */ DEFSYMBOL (Qwindowp); DEFSYMBOL (Qwindow_live_p); 1.1 XEmacs/xemacs/src/.dbxrc.in Index: .dbxrc.in =================================================================== ## -*- ksh -*- ## Copyright (C) 1998 Free Software Foundation, Inc. ## This file is part of XEmacs. ## XEmacs is free software; you can redistribute it and/or modify it ## under the terms of the GNU General Public License as published by the ## Free Software Foundation; either version 2, or (at your option) any ## later version. ## XEmacs is distributed in the hope that it will be useful, but WITHOUT ## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ## FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ## for more details. ## You should have received a copy of the GNU General Public License ## along with XEmacs; see the file COPYING. If not, write to ## the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ## Boston, MA 02111-1307, USA. ## Author: Martin Buchholz ## You can use this file to debug XEmacs using Sun WorkShop's dbx. ## Some functions defined here require a running process, but most ## don't. Considerable effort has been expended to this end. ## Since this file is called `.dbxrc', it will be read by dbx ## automatically when dbx is run in the build directory, which is where ## developers usually debug their xemacs. ## See also the comments in .gdbinit. ## See also the question of the XEmacs FAQ, titled ## "How to Debug an XEmacs problem with a debugger". ## gdb sources the ./.gdbinit in _addition_ to ~/.gdbinit. ## But dbx does _not_ source ~/.dbxrc if it found ./.dbxrc. ## So we simulate the gdb algorithm by doing it ourselves here. #define NOT_C_CODE #include "config.h" if test -r $HOME/.dbxrc; then . $HOME/.dbxrc; fi dbxenv language_mode ansic ignore POLL ignore IO #ifdef VDB_POSIX ignore SIGSEGV SIGBUS #endif document lbt << 'end' Usage: lbt Print the current Lisp stack trace. Requires a running xemacs process. end function lbt { call debug_backtrace() } document ldp << 'end' Usage: ldp lisp_object Print a Lisp Object value using the Lisp printer. Requires a running xemacs process. end function ldp { call debug_print ($1); } Lisp_Type_Int=-2 ## A bug in dbx prevents string variables from having values beginning with `-'!! function XEmacsInit { function ToInt { eval "$1=\$[(int) \`alloc.c\`$1]"; } ToInt dbg_USE_UNION_TYPE ToInt Lisp_Type_Char ToInt Lisp_Type_Record ToInt dbg_valbits ToInt dbg_gctypebits function ToLong { eval "$1=\$[(\`alloc.c\`unsigned long) \`alloc.c\`$1]"; } ToLong dbg_valmask ToLong dbg_typemask xemacs_initted=yes } function printvar { for i in $*; do eval "echo $i=\$$i"; done } document decode_object << 'end' Usage: decode_object lisp_object Extract implementation information from a Lisp Object. Defines variables $val, $type and $imp. end ## Various dbx bugs cause ugliness in following code function decode_object { if test -z "$xemacs_initted"; then XEmacsInit; fi; if test $dbg_USE_UNION_TYPE = 1; then ## Repeat after me... dbx sux, dbx sux, dbx sux... ## Allow both `pobj Qnil' and `pobj 0x82746834' to work case $(whatis $1) in *Lisp_Object*) obj="$[(`alloc.c`unsigned long)(($1).i)]";; *) obj="$[(`alloc.c`unsigned long)($1)]";; esac else obj="$[(`alloc.c`unsigned long)($1)]"; fi if test $[(int)($obj & 1)] = 1; then ## It's an int val=$[(long)(((unsigned long long)$obj) >> 1)] type=$Lisp_Type_Int else type=$[(int)(((void*)$obj) & $dbg_typemask)] if test $type = $Lisp_Type_Char; then val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)] else ## It's a record pointer val=$[(void*)$obj] if test "$val" = "(nil)"; then type=null_pointer; fi fi fi if test $type = $Lisp_Type_Record; then lheader="((struct lrecord_header *) $val)" lrecord_type=$[(enum lrecord_type) $lheader->type] imp=$[(void*)(`alloc.c`lrecord_implementations_table[$lheader->type])] else lheader="((struct lrecord_header *) -1)" lrecord_type=-1 imp="0xdeadbeef" fi ## printvar obj val type imp } function xint { decode_object "$*" print (long) ($val) } document xtype << 'end' Usage: xtype lisp_object Print the Lisp type of a lisp object. end function xtype { decode_object "$*" if test $type = $Lisp_Type_Int; then echo "int" elif test $type = $Lisp_Type_Char; then echo "char" elif test $type = null_pointer; then echo "null_pointer" else echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]" fi } function lisp-shadows { run -batch -vanilla -f list-load-path-shadows } function environment-to-run-temacs { unset EMACSLOADPATH export EMACSBOOTSTRAPLOADPATH=../lisp/:.. export EMACSBOOTSTRAPMODULEPATH=../modules/:.. } document run-temacs << 'end' Usage: run-temacs Run temacs interactively, like xemacs. Use this with debugging tools (like purify) that cannot deal with dumping, or when temacs builds successfully, but xemacs does not. end function run-temacs { environment-to-run-temacs run -nd -batch -l ../lisp/loadup.el run-temacs -q ${1+"$＠"} } document check-xemacs << 'end' Usage: check-xemacs Run the test suite. Equivalent to 'make check'. end function check-xemacs { run -batch -l ../tests/automated/test-harness.el -f batch-test-emacs ../tests/automated } document check-temacs << 'end' Usage: check-temacs Run the test suite on temacs. Equivalent to 'make check-temacs'. Use this with debugging tools (like purify) that cannot deal with dumping, or when temacs builds successfully, but xemacs does not. end function check-temacs { run-temacs -q -batch -l ../tests/automated/test-harness.el -f batch-test-emacs ../tests/automated } document update-elc << 'end' Usage: update-elc Run the core lisp byte compilation part of the build procedure. Use when debugging temacs, not xemacs! Use this when temacs builds successfully, but xemacs does not. end function update-elc { environment-to-run-temacs run -nd -batch -l ../lisp/update-elc.el } document dmp << 'end' Usage: dmp Run the dumping part of the build procedure. Use when debugging temacs, not xemacs! Use this when temacs builds successfully, but xemacs does not. end function dmp { environment-to-run-temacs run -nd -batch -l ../lisp/loadup.el dump } function pstruct { ## pstruct foo.c struct-name module "$1" > /dev/null type_ptr="((struct $2 *) $val)" print $type_ptr print *$type_ptr } document pobj << 'end' Usage: pobj lisp_object Print the internal C representation of a Lisp Object. end function pobj { decode_object $1 if test $type = $Lisp_Type_Int; then print -f"Integer: %d" $val elif test $type = $Lisp_Type_Char; then if test $[$val > 32 && $val < 128] = 1; then print -f"Char: %c" $val else print -f"Char: %d" $val fi elif test $lrecord_type = lrecord_type_string; then pstruct alloc.c Lisp_String elif test $lrecord_type = lrecord_type_cons; then pstruct alloc.c Lisp_Cons elif test $lrecord_type = lrecord_type_symbol; then pstruct symbols.c Lisp_Symbol echo "Symbol name: $[(char *)($type_ptr->name->data)]" elif test $lrecord_type = lrecord_type_vector; then pstruct alloc.c Lisp_Vector echo "Vector of length $[$type_ptr->size]" elif test $lrecord_type = lrecord_type_bit_vector; then pstruct fns.c Lisp_Bit_Vector elif test $lrecord_type = lrecord_type_buffer; then pstruct buffer.c buffer elif test $lrecord_type = lrecord_type_char_table; then pstruct chartab.c Lisp_Char_Table elif test $lrecord_type = lrecord_type_char_table_entry; then pstruct chartab.c Lisp_Char_Table_Entry elif test $lrecord_type = lrecord_type_charset; then pstruct mule-charset.c Lisp_Charset elif test $lrecord_type = lrecord_type_coding_system; then pstruct file-coding.c Lisp_Coding_System elif test $lrecord_type = lrecord_type_color_instance; then pstruct objects.c Lisp_Color_Instance elif test $lrecord_type = lrecord_type_command_builder; then pstruct event-stream.c command_builder elif test $lrecord_type = lrecord_type_compiled_function; then pstruct bytecode.c Lisp_Compiled_Function elif test $lrecord_type = lrecord_type_console; then pstruct console.c console elif test $lrecord_type = lrecord_type_database; then pstruct database.c Lisp_Database elif test $lrecord_type = lrecord_type_device; then pstruct device.c device elif test $lrecord_type = lrecord_type_event; then pstruct events.c Lisp_Event elif test $lrecord_type = lrecord_type_extent; then pstruct extents.c extent elif test $lrecord_type = lrecord_type_extent_auxiliary; then pstruct extents.c extent_auxiliary elif test $lrecord_type = lrecord_type_extent_info; then pstruct extents.c extent_info elif test $lrecord_type = lrecord_type_face; then pstruct faces.c Lisp_Face elif test $lrecord_type = lrecord_type_float; then pstruct floatfns.c Lisp_Float elif test $lrecord_type = lrecord_type_font_instance; then pstruct objects.c Lisp_Font_Instance elif test $lrecord_type = lrecord_type_frame; then pstruct frame.c frame elif test $lrecord_type = lrecord_type_glyph; then pstruct glyph.c Lisp_Glyph elif test $lrecord_type = lrecord_type_gui_item; then pstruct gui.c Lisp_Gui_Item elif test $lrecord_type = lrecord_type_hash_table; then pstruct elhash.c Lisp_Hash_Table elif test $lrecord_type = lrecord_type_image_instance; then pstruct glyphs.c Lisp_Image_Instance elif test $lrecord_type = lrecord_type_keymap; then pstruct keymap.c Lisp_Keymap elif test $lrecord_type = lrecord_type_lcrecord_list; then pstruct alloc.c lcrecord_list elif test $lrecord_type = lrecord_type_ldap; then pstruct ldap.c Lisp_LDAP elif test $lrecord_type = lrecord_type_lstream; then pstruct lstream.c lstream elif test $lrecord_type = lrecord_type_marker; then pstruct marker.c Lisp_Marker elif test $lrecord_type = lrecord_type_opaque; then pstruct opaque.c Lisp_Opaque elif test $lrecord_type = lrecord_type_opaque_ptr; then pstruct opaque.c Lisp_Opaque_Ptr elif test $lrecord_type = lrecord_type_popup_data; then pstruct gui-x.c popup_data elif test $lrecord_type = lrecord_type_process; then pstruct process.c Lisp_Process elif test $lrecord_type = lrecord_type_range_table; then pstruct rangetab.c Lisp_Range_Table elif test $lrecord_type = lrecord_type_specifier; then pstruct specifier.c Lisp_Specifier elif test $lrecord_type = lrecord_type_subr; then pstruct eval.c Lisp_Subr elif test $lrecord_type = lrecord_type_symbol_value_buffer_local; then pstruct symbols.c symbol_value_buffer_local elif test $lrecord_type = lrecord_type_symbol_value_forward; then pstruct symbols.c symbol_value_forward elif test $lrecord_type = lrecord_type_symbol_value_lisp_magic; then pstruct symbols.c symbol_value_lisp_magic elif test $lrecord_type = lrecord_type_symbol_value_varalias; then pstruct symbols.c symbol_value_varalias elif test $lrecord_type = lrecord_type_timeout; then pstruct event-stream.c Lisp_Timeout elif test $lrecord_type = lrecord_type_toolbar_button; then pstruct toolbar.c toolbar_button elif test $lrecord_type = lrecord_type_tooltalk_message; then pstruct tooltalk.c Lisp_Tooltalk_Message elif test $lrecord_type = lrecord_type_tooltalk_pattern; then pstruct tooltalk.c Lisp_Tooltalk_Pattern elif test $lrecord_type = lrecord_type_weak_list; then pstruct data.c weak_list elif test $lrecord_type = lrecord_type_window; then pstruct window.c window elif test $lrecord_type = lrecord_type_window_configuration; then pstruct window.c window_config elif test "$type" = "null_pointer"; then echo "Lisp Object is a null pointer!!" else echo "Unknown Lisp Object type" print $1 fi } dbxenv suppress_startup_message 4.0 ## dbxenv mt_watchpoints on function dp_core { print ((struct x_frame *)(((struct frame*)(Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget->core } ## Barf! function print_shell { print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget) } ## ------------------------------------------------------------- ## functions to test the debugging support itself. ## If you change this file, make sure the following still work... ## ------------------------------------------------------------- function test_xtype { function doit { echo -n "$1: "; xtype "$1"; } test_various_objects } function test_pobj { function doit { echo '==============================='; echo -n "$1: "; pobj "$1"; } test_various_objects } function test_various_objects { doit Vemacs_major_version doit Vhelp_char doit Qnil doit Qunbound doit Vobarray doit Vall_weak_lists doit Vxemacs_codename } 1.1 XEmacs/xemacs/src/.gdbinit.in Index: .gdbinit.in =================================================================== ## -*- ksh -*- ## Copyright (C) 1998 Free Software Foundation, Inc. ## This file is part of XEmacs. ## XEmacs is free software; you can redistribute it and/or modify it ## under the terms of the GNU General Public License as published by the ## Free Software Foundation; either version 2, or (at your option) any ## later version. ## XEmacs is distributed in the hope that it will be useful, but WITHOUT ## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ## FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ## for more details. ## You should have received a copy of the GNU General Public License ## along with XEmacs; see the file COPYING. If not, write to ## the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ## Boston, MA 02111-1307, USA. ## Author: Martin Buchholz ## Some useful commands for debugging emacs with gdb 4.16 or better. ## ## Since this file is called `.gdbinit', it will be read by gdb ## automatically when gdb is run in the build directory, which is where ## developers usually debug their xemacs. You can also source this ## file from your ~/.gdbinit, if you like. ## ## Configure xemacs with --debug, and compile with -g. ## ## See also the question of the XEmacs FAQ, titled ## "How to Debug an XEmacs problem with a debugger". ## ## This can be used to debug XEmacs no matter how the following are ## specified: ## USE_UNION_TYPE ## (the above all have configure equivalents) ## Some functions defined here require a running process, but most ## don't. Considerable effort has been expended to this end. ## See the dbg_ C support code in src/alloc.c that allows the functions ## defined in this file to work correctly. #define NOT_C_CODE #include "config.h" set print union off set print pretty off #ifdef VDB_POSIX handle SIGSEGV SIGBUS nostop noprint #endif set $Lisp_Type_Int = -2 define decode_object set $obj = (unsigned long) $arg0 if $obj & 1 ## It's an int set $val = $obj >> 1 set $type = $Lisp_Type_Int else set $type = $obj & dbg_typemask if $type == Lisp_Type_Char set $val = ($obj & dbg_valmask) >> dbg_gctypebits else ## It's a record pointer set $val = $obj end end if $type == Lisp_Type_Record set $lheader = ((struct lrecord_header *) $val) set $lrecord_type = ($lheader->type) set $imp = ((struct lrecord_implementation *) lrecord_implementations_table[(int) $lrecord_type]) else set $lrecord_type = -1 set $lheader = -1 set $imp = -1 end end document decode_object Usage: decode_object lisp_object Extract implementation information from a Lisp Object. Defines variables $val, $type and $imp. end define xint decode_object $arg0 print ((long) $val) end define xtype decode_object $arg0 if $type == $Lisp_Type_Int echo int\n else if $type == Lisp_Type_Char echo char\n else printf "record type: %s\n", $imp->name end end end document xtype Usage: xtype lisp_object Print the Lisp type of a lisp object. end define lisp-shadows run -batch -vanilla -f list-load-path-shadows end document lisp-shadows Usage: lisp-shadows Run xemacs to check for lisp shadows end define environment-to-run-temacs unset env EMACSLOADPATH set env EMACSBOOTSTRAPLOADPATH=../lisp/:.. set env EMACSBOOTSTRAPMODULEPATH=../modules/:.. end define run-temacs environment-to-run-temacs run -nd -batch -l ../lisp/loadup.el run-temacs -q end document run-temacs Usage: run-temacs Run temacs interactively, like xemacs. Use this with debugging tools (like purify) that cannot deal with dumping, or when temacs builds successfully, but xemacs does not. end define check-xemacs run -batch -l ../tests/automated/test-harness.el -f batch-test-emacs ../tests/automated end document check-xemacs Usage: check-xemacs Run the test suite. Equivalent to 'make check'. end define check-temacs environment-to-run-temacs run -nd -batch -l ../lisp/loadup.el run-temacs -q -batch -l ../tests/automated/test-harness.el -f batch-test-emacs ../tests/automated end document check-temacs Usage: check-temacs Run the test suite on temacs. Equivalent to 'make check-temacs'. Use this with debugging tools (like purify) that cannot deal with dumping, or when temacs builds successfully, but xemacs does not. end define update-elc environment-to-run-temacs run -nd -batch -l ../lisp/update-elc.el end document update-elc Usage: update-elc Run the core lisp byte compilation part of the build procedure. Use when debugging temacs, not xemacs! Use this when temacs builds successfully, but xemacs does not. end define dmp environment-to-run-temacs run -nd -batch -l ../lisp/loadup.el dump end document dmp Usage: dmp Run the dumping part of the build procedure. Use when debugging temacs, not xemacs! Use this when temacs builds successfully, but xemacs does not. end define ldp printf "%s", "Lisp => " call debug_print($arg0) end document ldp Usage: ldp lisp_object Print a Lisp Object value using the Lisp printer. Requires a running xemacs process. end define lbt call debug_backtrace() end document lbt Usage: lbt Print the current Lisp stack trace. Requires a running xemacs process. end define leval ldp Feval(Fcar(Fread_from_string(build_string($arg0),Qnil,Qnil))) end document leval Usage: leval "SEXP" Eval a lisp expression. Requires a running xemacs process. Example: (gdb) leval "(+ 1 2)" Lisp ==> 3 end define wtype print $arg0->core.widget_class->core_class.class_name end define xtname print XrmQuarkToString(((Object)($arg0))->object.xrm_name) end ## GDB's command language makes you want to ... define pptype set $type_ptr = ($arg0 *) $val print $type_ptr print *$type_ptr end define pstructtype set $type_ptr = (struct $arg0 *) $val print $type_ptr print *$type_ptr end define pobj decode_object $arg0 if $type == $Lisp_Type_Int printf "Integer: %d\n", $val else if $type == Lisp_Type_Char if $val > 32 && $val < 128 printf "Char: %c\n", $val else printf "Char: %d\n", $val end else if $lrecord_type == lrecord_type_string pptype Lisp_String else if $lrecord_type == lrecord_type_cons pptype Lisp_Cons else if $lrecord_type == lrecord_type_symbol pptype Lisp_Symbol printf "Symbol name: %s\n", ((Lisp_String *)$type_ptr->name)->data_ else if $lrecord_type == lrecord_type_vector pptype Lisp_Vector printf "Vector of length %d\n", $type_ptr->size ##print *($type_ptr->data) ＠ $type_ptr->size else if $lrecord_type == lrecord_type_bit_vector pptype Lisp_Bit_Vector else if $lrecord_type == lrecord_type_buffer pstructtype buffer else if $lrecord_type == lrecord_type_char_table pptype Lisp_Char_Table else if $lrecord_type == lrecord_type_char_table_entry pptype Lisp_Char_Table_Entry else if $lrecord_type == lrecord_type_charset pptype Lisp_Charset else if $lrecord_type == lrecord_type_coding_system pptype Lisp_Coding_System else if $lrecord_type == lrecord_type_color_instance pptype Lisp_Color_Instance else if $lrecord_type == lrecord_type_command_builder pptype command_builder else if $lrecord_type == lrecord_type_compiled_function pptype Lisp_Compiled_Function else if $lrecord_type == lrecord_type_console pstructtype console else if $lrecord_type == lrecord_type_database pptype Lisp_Database else if $lrecord_type == lrecord_type_device pstructtype device else if $lrecord_type == lrecord_type_event pptype Lisp_Event else if $lrecord_type == lrecord_type_extent pstructtype extent else if $lrecord_type == lrecord_type_extent_auxiliary pstructtype extent_auxiliary else if $lrecord_type == lrecord_type_extent_info pstructtype extent_info else if $lrecord_type == lrecord_type_face pptype Lisp_Face else if $lrecord_type == lrecord_type_float pptype Lisp_Float else if $lrecord_type == lrecord_type_font_instance pptype Lisp_Font_Instance else if $lrecord_type == lrecord_type_frame pstructtype frame else if $lrecord_type == lrecord_type_glyph pptype Lisp_Glyph else if $lrecord_type == lrecord_type_gui_item pptype Lisp_Gui_Item else if $lrecord_type == lrecord_type_hash_table pptype Lisp_Hash_Table else if $lrecord_type == lrecord_type_image_instance pptype Lisp_Image_Instance else if $lrecord_type == lrecord_type_keymap pptype Lisp_Keymap else if $lrecord_type == lrecord_type_lcrecord_list pstructtype lcrecord_list else if $lrecord_type == lrecord_type_ldap pptype Lisp_LDAP else if $lrecord_type == lrecord_type_lstream pstructtype lstream else if $lrecord_type == lrecord_type_marker pptype Lisp_Marker else if $lrecord_type == lrecord_type_opaque pptype Lisp_Opaque else if $lrecord_type == lrecord_type_opaque_ptr pptype Lisp_Opaque_Ptr else if $lrecord_type == lrecord_type_popup_data pptype popup_data else if $lrecord_type == lrecord_type_process pptype Lisp_Process else if $lrecord_type == lrecord_type_range_table pptype Lisp_Range_Table else if $lrecord_type == lrecord_type_specifier pptype Lisp_Specifier else if $lrecord_type == lrecord_type_subr pptype Lisp_Subr else if $lrecord_type == lrecord_type_symbol_value_buffer_local pstructtype symbol_value_buffer_local else if $lrecord_type == lrecord_type_symbol_value_forward pstructtype symbol_value_forward else if $lrecord_type == lrecord_type_symbol_value_lisp_magic pstructtype symbol_value_lisp_magic else if $lrecord_type == lrecord_type_symbol_value_varalias pstructtype symbol_value_varalias else if $lrecord_type == lrecord_type_timeout pptype Lisp_Timeout else if $lrecord_type == lrecord_type_toolbar_button pstructtype toolbar_button else if $lrecord_type == lrecord_type_tooltalk_message pptype Lisp_Tooltalk_Message else if $lrecord_type == lrecord_type_tooltalk_pattern pptype Lisp_Tooltalk_Pattern else if $lrecord_type == lrecord_type_weak_list pstructtype weak_list else if $lrecord_type == lrecord_type_window pstructtype window else if $lrecord_type == lrecord_type_window_configuration pstructtype window_config else if $lrecord_type == lrecord_type_fc_pattern pstructtype fc_pattern else if $lrecord_type == lrecord_type_fc_objectset pstructtype fc_objectset else if $lrecord_type == lrecord_type_fc_fontset pstructtype fc_fontset else echo Unknown Lisp Object type\n print $arg0 ## Barf, gag, retch end end end end end end end end end end end end end end end end end end end end ## Repeat after me... gdb sux, gdb sux, gdb sux... end end end end end end end end end end end end end end end end end end ## Are we having fun yet?? end end end end end end end end end end end end end end end end end end end document pobj Usage: pobj lisp_object Print the internal C representation of a Lisp Object. end ## ------------------------------------------------------------- ## functions to test the debugging support itself. ## If you change this file, make sure the following still work... ## ------------------------------------------------------------- define test_xtype printf "Vemacs_major_version: " xtype Vemacs_major_version printf "Vhelp_char: " xtype Vhelp_char printf "Qnil: " xtype Qnil printf "Qunbound: " xtype Qunbound printf "Vobarray: " xtype Vobarray printf "Vall_weak_lists: " xtype Vall_weak_lists printf "Vxemacs_codename: " xtype Vxemacs_codename end define test_pobj printf "Vemacs_major_version: " pobj Vemacs_major_version printf "Vhelp_char: " pobj Vhelp_char printf "Qnil: " pobj Qnil printf "Qunbound: " pobj Qunbound printf "Vobarray: " pobj Vobarray printf "Vall_weak_lists: " pobj Vall_weak_lists printf "Vxemacs_codename: " pobj Vxemacs_codename end 1.1 XEmacs/xemacs/src/gc.c Index: gc.c =================================================================== /* New incremental garbage collector for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" #include "backtrace.h" #include "buffer.h" #include "bytecode.h" #include "chartab.h" #include "console-stream.h" #include "device.h" #include "elhash.h" #include "events.h" #include "extents-impl.h" #include "file-coding.h" #include "frame-impl.h" #include "gc.h" #include "glyphs.h" #include "opaque.h" #include "lrecord.h" #include "lstream.h" #include "process.h" #include "profile.h" #include "redisplay.h" #include "specifier.h" #include "sysfile.h" #include "sysdep.h" #include "window.h" #include "vdb.h" #define GC_CONS_THRESHOLD 2000000 #define GC_CONS_INCREMENTAL_THRESHOLD 200000 #define GC_INCREMENTAL_TRAVERSAL_THRESHOLD 100000 /* Number of bytes of consing done since the last GC. */ EMACS_INT consing_since_gc; /* Number of bytes of consing done since startup. */ EMACS_UINT total_consing; /* Number of bytes of current allocated heap objects. */ EMACS_INT total_gc_usage; /* If the above is set. */ int total_gc_usage_set; /* Number of bytes of consing since gc before another gc should be done. */ EMACS_INT gc_cons_threshold; /* Nonzero during gc */ int gc_in_progress; /* Percentage of consing of total data size before another GC. */ EMACS_INT gc_cons_percentage; #ifdef NEW_GC /* Number of bytes of consing since gc before another cycle of the gc should be done in incremental mode. */ EMACS_INT gc_cons_incremental_threshold; /* Number of elements marked in one cycle of incremental GC. */ EMACS_INT gc_incremental_traversal_threshold; /* Nonzero during write barrier */ int write_barrier_enabled; #endif /* NEW_GC */  #ifdef NEW_GC /************************************************************************/ /* Incremental State and Statistics */ /************************************************************************/ enum gc_phase { NONE, INIT_GC, PUSH_ROOT_SET, MARK, REPUSH_ROOT_SET, FINISH_MARK, FINALIZE, SWEEP, FINISH_GC }; #ifndef ERROR_CHECK_GC struct { enum gc_phase phase; } gc_state; #else /* ERROR_CHECK_GC */ enum gc_stat_id { GC_STAT_TOTAL, GC_STAT_IN_LAST_GC, GC_STAT_IN_THIS_GC, GC_STAT_IN_LAST_CYCLE, GC_STAT_IN_THIS_CYCLE, GC_STAT_COUNT /* has to be last */ }; struct { enum gc_phase phase; EMACS_INT n_gc[GC_STAT_COUNT]; EMACS_INT n_cycles[GC_STAT_COUNT]; EMACS_INT enqueued[GC_STAT_COUNT]; EMACS_INT dequeued[GC_STAT_COUNT]; EMACS_INT repushed[GC_STAT_COUNT]; EMACS_INT enqueued2[GC_STAT_COUNT]; EMACS_INT dequeued2[GC_STAT_COUNT]; EMACS_INT finalized[GC_STAT_COUNT]; EMACS_INT freed[GC_STAT_COUNT]; EMACS_INT explicitly_freed; EMACS_INT explicitly_tried_freed; } gc_state; #endif /* ERROR_CHECK_GC */ #define GC_PHASE gc_state.phase #define GC_SET_PHASE(p) GC_PHASE = p #ifdef ERROR_CHECK_GC # define GC_STAT_START_NEW_GC gc_stat_start_new_gc () # define GC_STAT_RESUME_GC gc_stat_resume_gc () #define GC_STAT_TICK(STAT) \ gc_state.STAT[GC_STAT_TOTAL]++; \ gc_state.STAT[GC_STAT_IN_THIS_GC]++; \ gc_state.STAT[GC_STAT_IN_THIS_CYCLE]++ # define GC_STAT_ENQUEUED \ if (GC_PHASE == REPUSH_ROOT_SET) \ { \ GC_STAT_TICK (enqueued2); \ } \ else \ { \ GC_STAT_TICK (enqueued); \ } # define GC_STAT_DEQUEUED \ if (gc_state.phase == REPUSH_ROOT_SET) \ { \ GC_STAT_TICK (dequeued2); \ } \ else \ { \ GC_STAT_TICK (dequeued); \ } # define GC_STAT_REPUSHED GC_STAT_TICK (repushed) #define GC_STAT_RESUME(stat) \ gc_state.stat[GC_STAT_IN_LAST_CYCLE] = \ gc_state.stat[GC_STAT_IN_THIS_CYCLE]; \ gc_state.stat[GC_STAT_IN_THIS_CYCLE] = 0 #define GC_STAT_RESTART(stat) \ gc_state.stat[GC_STAT_IN_LAST_GC] = \ gc_state.stat[GC_STAT_IN_THIS_GC]; \ gc_state.stat[GC_STAT_IN_THIS_GC] = 0; \ GC_STAT_RESUME (stat) void gc_stat_start_new_gc (void) { gc_state.n_gc[GC_STAT_TOTAL]++; gc_state.n_cycles[GC_STAT_TOTAL]++; gc_state.n_cycles[GC_STAT_IN_LAST_GC] = gc_state.n_cycles[GC_STAT_IN_THIS_GC]; gc_state.n_cycles[GC_STAT_IN_THIS_GC] = 1; GC_STAT_RESTART (enqueued); GC_STAT_RESTART (dequeued); GC_STAT_RESTART (repushed); GC_STAT_RESTART (finalized); GC_STAT_RESTART (enqueued2); GC_STAT_RESTART (dequeued2); GC_STAT_RESTART (freed); } void gc_stat_resume_gc (void) { gc_state.n_cycles[GC_STAT_TOTAL]++; gc_state.n_cycles[GC_STAT_IN_THIS_GC]++; GC_STAT_RESUME (enqueued); GC_STAT_RESUME (dequeued); GC_STAT_RESUME (repushed); GC_STAT_RESUME (finalized); GC_STAT_RESUME (enqueued2); GC_STAT_RESUME (dequeued2); GC_STAT_RESUME (freed); } void gc_stat_finalized (void) { GC_STAT_TICK (finalized); } void gc_stat_freed (void) { GC_STAT_TICK (freed); } void gc_stat_explicitly_freed (void) { gc_state.explicitly_freed++; } void gc_stat_explicitly_tried_freed (void) { gc_state.explicitly_tried_freed++; } #define GC_STAT_PRINT_ONE(stat) \ printf (" | %9s %10d %10d %10d %10d %10d\n", \ #stat, \ (int) gc_state.stat[GC_STAT_TOTAL], \ (int) gc_state.stat[GC_STAT_IN_LAST_GC], \ (int) gc_state.stat[GC_STAT_IN_THIS_GC], \ (int) gc_state.stat[GC_STAT_IN_LAST_CYCLE], \ (int) gc_state.stat[GC_STAT_IN_THIS_CYCLE]) void gc_stat_print_stats (void) { printf (" | PHASE %d TOTAL_GC %d\n", (int) GC_PHASE, (int) gc_state.n_gc[GC_STAT_TOTAL]); printf (" | %9s %10s %10s %10s %10s %10s\n", "stat", "total", "last_gc", "this_gc", "last_cycle", "this_cycle"); printf (" | %9s %10d %10d %10d \n", "cycle", (int) gc_state.n_cycles[GC_STAT_TOTAL], (int) gc_state.n_cycles[GC_STAT_IN_LAST_GC], (int) gc_state.n_cycles[GC_STAT_IN_THIS_GC]); GC_STAT_PRINT_ONE (enqueued); GC_STAT_PRINT_ONE (dequeued); GC_STAT_PRINT_ONE (repushed); GC_STAT_PRINT_ONE (enqueued2); GC_STAT_PRINT_ONE (dequeued2); GC_STAT_PRINT_ONE (finalized); GC_STAT_PRINT_ONE (freed); printf (" | explicitly freed %d tried %d\n", (int) gc_state.explicitly_freed, (int) gc_state.explicitly_tried_freed); } DEFUN("gc-stats", Fgc_stats, 0, 0 ,"", /* Return statistics about garbage collection cycles in a property list. */ ()) { Lisp_Object pl = Qnil; #define PL(name,value) \ pl = cons3 (intern (name), make_int ((int) gc_state.value), pl) PL ("explicitly-tried-freed", explicitly_tried_freed); PL ("explicitly-freed", explicitly_freed); PL ("freed-in-this-cycle", freed[GC_STAT_IN_THIS_CYCLE]); PL ("freed-in-this-gc", freed[GC_STAT_IN_THIS_GC]); PL ("freed-in-last-cycle", freed[GC_STAT_IN_LAST_CYCLE]); PL ("freed-in-last-gc", freed[GC_STAT_IN_LAST_GC]); PL ("freed-total", freed[GC_STAT_TOTAL]); PL ("finalized-in-this-cycle", finalized[GC_STAT_IN_THIS_CYCLE]); PL ("finalized-in-this-gc", finalized[GC_STAT_IN_THIS_GC]); PL ("finalized-in-last-cycle", finalized[GC_STAT_IN_LAST_CYCLE]); PL ("finalized-in-last-gc", finalized[GC_STAT_IN_LAST_GC]); PL ("finalized-total", finalized[GC_STAT_TOTAL]); PL ("repushed-in-this-cycle", repushed[GC_STAT_IN_THIS_CYCLE]); PL ("repushed-in-this-gc", repushed[GC_STAT_IN_THIS_GC]); PL ("repushed-in-last-cycle", repushed[GC_STAT_IN_LAST_CYCLE]); PL ("repushed-in-last-gc", repushed[GC_STAT_IN_LAST_GC]); PL ("repushed-total", repushed[GC_STAT_TOTAL]); PL ("dequeued2-in-this-cycle", dequeued2[GC_STAT_IN_THIS_CYCLE]); PL ("dequeued2-in-this-gc", dequeued2[GC_STAT_IN_THIS_GC]); PL ("dequeued2-in-last-cycle", dequeued2[GC_STAT_IN_LAST_CYCLE]); PL ("dequeued2-in-last-gc", dequeued2[GC_STAT_IN_LAST_GC]); PL ("dequeued2-total", dequeued2[GC_STAT_TOTAL]); PL ("enqueued2-in-this-cycle", enqueued2[GC_STAT_IN_THIS_CYCLE]); PL ("enqueued2-in-this-gc", enqueued2[GC_STAT_IN_THIS_GC]); PL ("enqueued2-in-last-cycle", enqueued2[GC_STAT_IN_LAST_CYCLE]); PL ("enqueued2-in-last-gc", enqueued2[GC_STAT_IN_LAST_GC]); PL ("enqueued2-total", enqueued2[GC_STAT_TOTAL]); PL ("dequeued-in-this-cycle", dequeued[GC_STAT_IN_THIS_CYCLE]); PL ("dequeued-in-this-gc", dequeued[GC_STAT_IN_THIS_GC]); PL ("dequeued-in-last-cycle", dequeued[GC_STAT_IN_LAST_CYCLE]); PL ("dequeued-in-last-gc", dequeued[GC_STAT_IN_LAST_GC]); PL ("dequeued-total", dequeued[GC_STAT_TOTAL]); PL ("enqueued-in-this-cycle", enqueued[GC_STAT_IN_THIS_CYCLE]); PL ("enqueued-in-this-gc", enqueued[GC_STAT_IN_THIS_GC]); PL ("enqueued-in-last-cycle", enqueued[GC_STAT_IN_LAST_CYCLE]); PL ("enqueued-in-last-gc", enqueued[GC_STAT_IN_LAST_GC]); PL ("enqueued-total", enqueued[GC_STAT_TOTAL]); PL ("n-cycles-in-this-gc", n_cycles[GC_STAT_IN_THIS_GC]); PL ("n-cycles-in-last-gc", n_cycles[GC_STAT_IN_LAST_GC]); PL ("n-cycles-total", n_cycles[GC_STAT_TOTAL]); PL ("n-gc-total", n_gc[GC_STAT_TOTAL]); PL ("phase", phase); return pl; } #else /* not ERROR_CHECK_GC */ # define GC_STAT_START_NEW_GC # define GC_STAT_RESUME_GC # define GC_STAT_ENQUEUED # define GC_STAT_DEQUEUED # define GC_STAT_REPUSHED # define GC_STAT_REMOVED #endif /* not ERROR_CHECK_GC */ #endif /* NEW_GC */  /************************************************************************/ /* Recompute need to garbage collect */ /************************************************************************/ int need_to_garbage_collect; #ifdef ERROR_CHECK_GC int always_gc = 0; /* Debugging hack; equivalent to (setq gc-cons-thresold -1) */ #else #define always_gc 0 #endif /* True if it's time to garbage collect now. */ void recompute_need_to_garbage_collect (void) { if (always_gc) need_to_garbage_collect = 1; else need_to_garbage_collect = #ifdef NEW_GC write_barrier_enabled ? (consing_since_gc > gc_cons_incremental_threshold) : #endif /* NEW_GC */ (consing_since_gc > gc_cons_threshold && #if 0 /* #### implement this better */ (100 * consing_since_gc) / total_data_usage () >= gc_cons_percentage #else (!total_gc_usage_set || (100 * consing_since_gc) / total_gc_usage >= gc_cons_percentage) #endif ); recompute_funcall_allocation_flag (); }  /************************************************************************/ /* Mark Phase */ /************************************************************************/ static const struct memory_description lisp_object_description_1[] = { { XD_LISP_OBJECT, 0 }, { XD_END } }; const struct sized_memory_description lisp_object_description = { sizeof (Lisp_Object), lisp_object_description_1 }; #if defined (USE_KKCC) || defined (PDUMP) /* This function extracts the value of a count variable described somewhere else in the description. It is converted corresponding to the type */ EMACS_INT lispdesc_indirect_count_1 (EMACS_INT code, const struct memory_description *idesc, const void *idata) { EMACS_INT count; const void *irdata; int line = XD_INDIRECT_VAL (code); int delta = XD_INDIRECT_DELTA (code); irdata = ((char *) idata) + lispdesc_indirect_count (idesc[line].offset, idesc, idata); switch (idesc[line].type) { case XD_BYTECOUNT: count = * (Bytecount *) irdata; break; case XD_ELEMCOUNT: count = * (Elemcount *) irdata; break; case XD_HASHCODE: count = * (Hashcode *) irdata; break; case XD_INT: count = * (int *) irdata; break; case XD_LONG: count = * (long *) irdata; break; default: stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", idesc[line].type, line, (long) code); #if defined(USE_KKCC) && defined(DEBUG_XEMACS) if (gc_in_progress) kkcc_backtrace (); #endif #ifdef PDUMP if (in_pdump) pdump_backtrace (); #endif count = 0; /* warning suppression */ ABORT (); } count += delta; return count; } /* SDESC is a "description map" (basically, a list of offsets used for successive indirections) and OBJ is the first object to indirect off of. Return the description ultimately found. */ const struct sized_memory_description * lispdesc_indirect_description_1 (const void *obj, const struct sized_memory_description *sdesc) { int pos; for (pos = 0; sdesc[pos].size >= 0; pos++) obj = * (const void **) ((const char *) obj + sdesc[pos].size); return (const struct sized_memory_description *) obj; } /* Compute the size of the data at RDATA, described by a single entry DESC1 in a description array. OBJ and DESC are used for XD_INDIRECT references. */ static Bytecount lispdesc_one_description_line_size (void *rdata, const struct memory_description *desc1, const void *obj, const struct memory_description *desc) { union_switcheroo: switch (desc1->type) { case XD_LISP_OBJECT_ARRAY: { EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); return (val * sizeof (Lisp_Object)); } case XD_LISP_OBJECT: case XD_LO_LINK: return sizeof (Lisp_Object); case XD_OPAQUE_PTR: return sizeof (void *); #ifdef NEW_GC case XD_LISP_OBJECT_BLOCK_PTR: #endif /* NEW_GC */ case XD_BLOCK_PTR: { EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); return val * sizeof (void *); } case XD_BLOCK_ARRAY: { EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); return (val * lispdesc_block_size (rdata, lispdesc_indirect_description (obj, desc1->data2.descr))); } case XD_OPAQUE_DATA_PTR: return sizeof (void *); case XD_UNION_DYNAMIC_SIZE: { /* If an explicit size was given in the first-level structure description, use it; else compute size based on current union constant. */ const struct sized_memory_description *sdesc = lispdesc_indirect_description (obj, desc1->data2.descr); if (sdesc->size) return sdesc->size; else { desc1 = lispdesc_process_xd_union (desc1, desc, obj); if (desc1) goto union_switcheroo; break; } } case XD_UNION: { /* If an explicit size was given in the first-level structure description, use it; else compute size based on maximum of all possible structures. */ const struct sized_memory_description *sdesc = lispdesc_indirect_description (obj, desc1->data2.descr); if (sdesc->size) return sdesc->size; else { int count; Bytecount max_size = -1, size; desc1 = sdesc->description; for (count = 0; desc1[count].type != XD_END; count++) { size = lispdesc_one_description_line_size (rdata, &desc1[count], obj, desc); if (size > max_size) max_size = size; } return max_size; } } case XD_ASCII_STRING: return sizeof (void *); case XD_DOC_STRING: return sizeof (void *); case XD_INT_RESET: return sizeof (int); case XD_BYTECOUNT: return sizeof (Bytecount); case XD_ELEMCOUNT: return sizeof (Elemcount); case XD_HASHCODE: return sizeof (Hashcode); case XD_INT: return sizeof (int); case XD_LONG: return sizeof (long); default: stderr_out ("Unsupported dump type : %d\n", desc1->type); ABORT (); } return 0; } /* Return the size of the memory block (NOT necessarily a structure!) described by SDESC and pointed to by OBJ. If SDESC records an explicit size (i.e. non-zero), it is simply returned; otherwise, the size is calculated by the maximum offset and the size of the object at that offset, rounded up to the maximum alignment. In this case, we may need the object, for example when retrieving an "indirect count" of an inlined array (the count is not constant, but is specified by one of the elements of the memory block). (It is generally not a problem if we return an overly large size -- we will simply end up reserving more space than necessary; but if the size is too small we could be in serious trouble, in particular with nested inlined structures, where there may be alignment padding in the middle of a block. #### In fact there is an (at least theoretical) problem with an overly large size -- we may trigger a protection fault when reading from invalid memory. We need to handle this -- perhaps in a stupid but dependable way, i.e. by trapping SIGSEGV and SIGBUS.) */ Bytecount lispdesc_block_size_1 (const void *obj, Bytecount size, const struct memory_description *desc) { EMACS_INT max_offset = -1; int max_offset_pos = -1; int pos; if (size) return size; for (pos = 0; desc[pos].type != XD_END; pos++) { EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); if (offset == max_offset) { stderr_out ("Two relocatable elements at same offset?\n"); ABORT (); } else if (offset > max_offset) { max_offset = offset; max_offset_pos = pos; } } if (max_offset_pos < 0) return 0; { Bytecount size_at_max; size_at_max = lispdesc_one_description_line_size ((char *) obj + max_offset, &desc[max_offset_pos], obj, desc); /* We have no way of knowing the required alignment for this structure, so just make it maximally aligned. */ return MAX_ALIGN_SIZE (max_offset + size_at_max); } } #endif /* defined (USE_KKCC) || defined (PDUMP) */ #ifdef MC_ALLOC #define GC_CHECK_NOT_FREE(lheader) \ gc_checking_assert (! LRECORD_FREE_P (lheader)); #else /* MC_ALLOC */ #define GC_CHECK_NOT_FREE(lheader) \ gc_checking_assert (! LRECORD_FREE_P (lheader)); \ gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ ! ((struct old_lcrecord_header *) lheader)->free) #endif /* MC_ALLOC */ #ifdef USE_KKCC /* The following functions implement the new mark algorithm. They mark objects according to their descriptions. They are modeled on the corresponding pdumper procedures. */ #if 0 # define KKCC_STACK_AS_QUEUE 1 #endif #ifdef DEBUG_XEMACS /* The backtrace for the KKCC mark functions. */ #define KKCC_INIT_BT_STACK_SIZE 4096 typedef struct { void *obj; const struct memory_description *desc; int pos; } kkcc_bt_stack_entry; static kkcc_bt_stack_entry *kkcc_bt; static int kkcc_bt_stack_size; static int kkcc_bt_depth = 0; static void kkcc_bt_init (void) { kkcc_bt_depth = 0; kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE; kkcc_bt = (kkcc_bt_stack_entry *) xmalloc_and_zero (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); if (!kkcc_bt) { stderr_out ("KKCC backtrace stack init failed for size %d\n", kkcc_bt_stack_size); ABORT (); } } void kkcc_backtrace (void) { int i; stderr_out ("KKCC mark stack backtrace :\n"); for (i = kkcc_bt_depth - 1; i >= 0; i--) { Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj); stderr_out (" [%d]", i); if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type) || (!LRECORDP (obj)) || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) { stderr_out (" non Lisp Object"); } else { stderr_out (" %s", XRECORD_LHEADER_IMPLEMENTATION (obj)->name); } stderr_out (" (addr: 0x%x, desc: 0x%x, ", (int) kkcc_bt[i].obj, (int) kkcc_bt[i].desc); if (kkcc_bt[i].pos >= 0) stderr_out ("pos: %d)\n", kkcc_bt[i].pos); else if (kkcc_bt[i].pos == -1) stderr_out ("root set)\n"); else if (kkcc_bt[i].pos == -2) stderr_out ("dirty object)\n"); } } static void kkcc_bt_stack_realloc (void) { kkcc_bt_stack_size *= 2; kkcc_bt = (kkcc_bt_stack_entry *) xrealloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); if (!kkcc_bt) { stderr_out ("KKCC backtrace stack realloc failed for size %d\n", kkcc_bt_stack_size); ABORT (); } } static void kkcc_bt_free (void) { xfree_1 (kkcc_bt); kkcc_bt = 0; kkcc_bt_stack_size = 0; } static void kkcc_bt_push (void *obj, const struct memory_description *desc, int level, int pos) { kkcc_bt_depth = level; kkcc_bt[kkcc_bt_depth].obj = obj; kkcc_bt[kkcc_bt_depth].desc = desc; kkcc_bt[kkcc_bt_depth].pos = pos; kkcc_bt_depth++; if (kkcc_bt_depth >= kkcc_bt_stack_size) kkcc_bt_stack_realloc (); } #else /* not DEBUG_XEMACS */ #define kkcc_bt_init() #define kkcc_bt_push(obj, desc, level, pos) #endif /* not DEBUG_XEMACS */ /* Object memory descriptions are in the lrecord_implementation structure. But copying them to a parallel array is much more cache-friendly. */ const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)]; /* the initial stack size in kkcc_gc_stack_entries */ #define KKCC_INIT_GC_STACK_SIZE 16384 typedef struct { void *data; const struct memory_description *desc; #ifdef DEBUG_XEMACS int level; int pos; #endif } kkcc_gc_stack_entry; static kkcc_gc_stack_entry *kkcc_gc_stack_ptr; static int kkcc_gc_stack_front; static int kkcc_gc_stack_rear; static int kkcc_gc_stack_size; #define KKCC_INC(i) ((i + 1) % kkcc_gc_stack_size) #define KKCC_INC2(i) ((i + 2) % kkcc_gc_stack_size) #define KKCC_GC_STACK_FULL (KKCC_INC2 (kkcc_gc_stack_rear) == kkcc_gc_stack_front) #define KKCC_GC_STACK_EMPTY (KKCC_INC (kkcc_gc_stack_rear) == kkcc_gc_stack_front) static void kkcc_gc_stack_init (void) { kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE; kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) xmalloc_and_zero (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); if (!kkcc_gc_stack_ptr) { stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size); ABORT (); } kkcc_gc_stack_front = 0; kkcc_gc_stack_rear = kkcc_gc_stack_size - 1; } static void kkcc_gc_stack_free (void) { xfree_1 (kkcc_gc_stack_ptr); kkcc_gc_stack_ptr = 0; kkcc_gc_stack_front = 0; kkcc_gc_stack_rear = 0; kkcc_gc_stack_size = 0; } static void kkcc_gc_stack_realloc (void) { kkcc_gc_stack_entry *old_ptr = kkcc_gc_stack_ptr; int old_size = kkcc_gc_stack_size; kkcc_gc_stack_size *= 2; kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) xmalloc_and_zero (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); if (!kkcc_gc_stack_ptr) { stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size); ABORT (); } if (kkcc_gc_stack_rear >= kkcc_gc_stack_front) { int number_elements = kkcc_gc_stack_rear - kkcc_gc_stack_front + 1; memcpy (kkcc_gc_stack_ptr, &old_ptr[kkcc_gc_stack_front], number_elements * sizeof (kkcc_gc_stack_entry)); kkcc_gc_stack_front = 0; kkcc_gc_stack_rear = number_elements - 1; } else { int number_elements = old_size - kkcc_gc_stack_front; memcpy (kkcc_gc_stack_ptr, &old_ptr[kkcc_gc_stack_front], number_elements * sizeof (kkcc_gc_stack_entry)); memcpy (&kkcc_gc_stack_ptr[number_elements], &old_ptr[0], (kkcc_gc_stack_rear + 1) * sizeof (kkcc_gc_stack_entry)); kkcc_gc_stack_front = 0; kkcc_gc_stack_rear = kkcc_gc_stack_rear + number_elements; } xfree_1 (old_ptr); } static void #ifdef DEBUG_XEMACS kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc, int level, int pos) #else kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc) #endif { #ifdef NEW_GC GC_STAT_ENQUEUED; #endif /* NEW_GC */ if (KKCC_GC_STACK_FULL) kkcc_gc_stack_realloc(); kkcc_gc_stack_rear = KKCC_INC (kkcc_gc_stack_rear); kkcc_gc_stack_ptr[kkcc_gc_stack_rear].data = data; kkcc_gc_stack_ptr[kkcc_gc_stack_rear].desc = desc; #ifdef DEBUG_XEMACS kkcc_gc_stack_ptr[kkcc_gc_stack_rear].level = level; kkcc_gc_stack_ptr[kkcc_gc_stack_rear].pos = pos; #endif } #ifdef DEBUG_XEMACS #define kkcc_gc_stack_push(data, desc, level, pos) \ kkcc_gc_stack_push_1 (data, desc, level, pos) #else #define kkcc_gc_stack_push(data, desc, level, pos) \ kkcc_gc_stack_push_1 (data, desc) #endif static kkcc_gc_stack_entry * kkcc_gc_stack_pop (void) { if (KKCC_GC_STACK_EMPTY) return 0; #ifdef NEW_GC GC_STAT_DEQUEUED; #endif /* NEW_GC */ #ifndef KKCC_STACK_AS_QUEUE /* stack behaviour */ return &kkcc_gc_stack_ptr[kkcc_gc_stack_rear--]; #else /* queue behaviour */ { int old_front = kkcc_gc_stack_front; kkcc_gc_stack_front = KKCC_INC (kkcc_gc_stack_front); return &kkcc_gc_stack_ptr[old_front]; } #endif } void #ifdef DEBUG_XEMACS kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos) #else kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj) #endif { if (XTYPE (obj) == Lisp_Type_Record) { struct lrecord_header *lheader = XRECORD_LHEADER (obj); const struct memory_description *desc; GC_CHECK_LHEADER_INVARIANTS (lheader); desc = RECORD_DESCRIPTION (lheader); if (! MARKED_RECORD_HEADER_P (lheader)) { #ifdef NEW_GC MARK_GREY (lheader); #else /* not NEW_GC */ MARK_RECORD_HEADER (lheader); #endif /* not NEW_GC */ kkcc_gc_stack_push ((void *) lheader, desc, level, pos); } } } #ifdef NEW_GC #ifdef DEBUG_XEMACS #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) #else #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ kkcc_gc_stack_push_lisp_object_1 (obj) #endif void #ifdef DEBUG_XEMACS kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj, int level, int pos) #else kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj) #endif { if (XTYPE (obj) == Lisp_Type_Record) { struct lrecord_header *lheader = XRECORD_LHEADER (obj); const struct memory_description *desc; GC_STAT_REPUSHED; GC_CHECK_LHEADER_INVARIANTS (lheader); desc = RECORD_DESCRIPTION (lheader); MARK_GREY (lheader); kkcc_gc_stack_push ((void*) lheader, desc, level, pos); } } #endif /* NEW_GC */ #ifdef ERROR_CHECK_GC #define KKCC_DO_CHECK_FREE(obj, allow_free) \ do \ { \ if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \ { \ struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ GC_CHECK_NOT_FREE (lheader); \ } \ } while (0) #else #define KKCC_DO_CHECK_FREE(obj, allow_free) #endif #ifdef ERROR_CHECK_GC #ifdef DEBUG_XEMACS static void mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free, int level, int pos) #else static void mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free) #endif { KKCC_DO_CHECK_FREE (obj, allow_free); kkcc_gc_stack_push_lisp_object (obj, level, pos); } #ifdef DEBUG_XEMACS #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ mark_object_maybe_checking_free_1 (obj, allow_free, level, pos) #else #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ mark_object_maybe_checking_free_1 (obj, allow_free) #endif #else /* not ERROR_CHECK_GC */ #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ kkcc_gc_stack_push_lisp_object (obj, level, pos) #endif /* not ERROR_CHECK_GC */ /* This function loops all elements of a struct pointer and calls mark_with_description with each element. */ static void #ifdef DEBUG_XEMACS mark_struct_contents_1 (const void *data, const struct sized_memory_description *sdesc, int count, int level, int pos) #else mark_struct_contents_1 (const void *data, const struct sized_memory_description *sdesc, int count) #endif { int i; Bytecount elsize; elsize = lispdesc_block_size (data, sdesc); for (i = 0; i < count; i++) { kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description, level, pos); } } #ifdef DEBUG_XEMACS #define mark_struct_contents(data, sdesc, count, level, pos) \ mark_struct_contents_1 (data, sdesc, count, level, pos) #else #define mark_struct_contents(data, sdesc, count, level, pos) \ mark_struct_contents_1 (data, sdesc, count) #endif #ifdef NEW_GC /* This function loops all elements of a struct pointer and calls mark_with_description with each element. */ static void #ifdef DEBUG_XEMACS mark_lisp_object_block_contents_1 (const void *data, const struct sized_memory_description *sdesc, int count, int level, int pos) #else mark_lisp_object_block_contents_1 (const void *data, const struct sized_memory_description *sdesc, int count) #endif { int i; Bytecount elsize; elsize = lispdesc_block_size (data, sdesc); for (i = 0; i < count; i++) { const Lisp_Object obj = wrap_pointer_1 (((char *) data) + elsize * i); if (XTYPE (obj) == Lisp_Type_Record) { struct lrecord_header *lheader = XRECORD_LHEADER (obj); const struct memory_description *desc; GC_CHECK_LHEADER_INVARIANTS (lheader); desc = sdesc->description; if (! MARKED_RECORD_HEADER_P (lheader)) { MARK_GREY (lheader); kkcc_gc_stack_push ((void *) lheader, desc, level, pos); } } } } #ifdef DEBUG_XEMACS #define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \ mark_lisp_object_block_contents_1 (data, sdesc, count, level, pos) #else #define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \ mark_lisp_object_block_contents_1 (data, sdesc, count) #endif #endif /* not NEW_GC */ /* This function implements the KKCC mark algorithm. Instead of calling mark_object, all the alive Lisp_Objects are pushed on the kkcc_gc_stack. This function processes all elements on the stack according to their descriptions. */ static void kkcc_marking ( #ifdef NEW_GC int cnt #else /* not NEW_GC */ int UNUSED(cnt) #endif /* not NEW_GC */ ) { kkcc_gc_stack_entry *stack_entry = 0; void *data = 0; const struct memory_description *desc = 0; int pos; #ifdef NEW_GC int count = cnt; #endif /* NEW_GC */ #ifdef DEBUG_XEMACS int level = 0; #endif while ((stack_entry = kkcc_gc_stack_pop ()) != 0) { data = stack_entry->data; desc = stack_entry->desc; #ifdef DEBUG_XEMACS level = stack_entry->level + 1; #endif kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos); #ifdef NEW_GC /* Mark black if object is currently grey. This first checks, if the object is really allocated on the mc-heap. If it is, it can be marked black; if it is not, it cannot be marked. */ maybe_mark_black (data); #endif /* NEW_GC */ if (!data) continue; gc_checking_assert (data); gc_checking_assert (desc); for (pos = 0; desc[pos].type != XD_END; pos++) { const struct memory_description *desc1 = &desc[pos]; const void *rdata = (const char *) data + lispdesc_indirect_count (desc1->offset, desc, data); union_switcheroo: /* If the flag says don't mark, then don't mark. */ if ((desc1->flags) & XD_FLAG_NO_KKCC) continue; switch (desc1->type) { case XD_BYTECOUNT: case XD_ELEMCOUNT: case XD_HASHCODE: case XD_INT: case XD_LONG: case XD_INT_RESET: case XD_LO_LINK: case XD_OPAQUE_PTR: case XD_OPAQUE_DATA_PTR: case XD_ASCII_STRING: case XD_DOC_STRING: break; case XD_LISP_OBJECT: { const Lisp_Object *stored_obj = (const Lisp_Object *) rdata; /* Because of the way that tagged objects work (pointers and Lisp_Objects have the same representation), XD_LISP_OBJECT can be used for untagged pointers. They might be NULL, though. */ if (EQ (*stored_obj, Qnull_pointer)) break; #ifdef MC_ALLOC mark_object_maybe_checking_free (*stored_obj, 0, level, pos); #else /* not MC_ALLOC */ mark_object_maybe_checking_free (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, level, pos); #endif /* not MC_ALLOC */ break; } case XD_LISP_OBJECT_ARRAY: { int i; EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); for (i = 0; i < count; i++) { const Lisp_Object *stored_obj = (const Lisp_Object *) rdata + i; if (EQ (*stored_obj, Qnull_pointer)) break; #ifdef MC_ALLOC mark_object_maybe_checking_free (*stored_obj, 0, level, pos); #else /* not MC_ALLOC */ mark_object_maybe_checking_free (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, level, pos); #endif /* not MC_ALLOC */ } break; } #ifdef NEW_GC case XD_LISP_OBJECT_BLOCK_PTR: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = lispdesc_indirect_description (data, desc1->data2.descr); const char *dobj = * (const char **) rdata; if (dobj) mark_lisp_object_block_contents (dobj, sdesc, count, level, pos); break; } #endif /* NEW_GC */ case XD_BLOCK_PTR: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = lispdesc_indirect_description (data, desc1->data2.descr); const char *dobj = * (const char **) rdata; if (dobj) mark_struct_contents (dobj, sdesc, count, level, pos); break; } case XD_BLOCK_ARRAY: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); const struct sized_memory_description *sdesc = lispdesc_indirect_description (data, desc1->data2.descr); mark_struct_contents (rdata, sdesc, count, level, pos); break; } case XD_UNION: case XD_UNION_DYNAMIC_SIZE: desc1 = lispdesc_process_xd_union (desc1, desc, data); if (desc1) goto union_switcheroo; break; default: stderr_out ("Unsupported description type : %d\n", desc1->type); kkcc_backtrace (); ABORT (); } } #ifdef NEW_GC if (cnt) if (!--count) break; #endif /* NEW_GC */ } } #endif /* USE_KKCC */ /* I hate duplicating all this crap! */ int marked_p (Lisp_Object obj) { /* Checks we used to perform. */ /* if (EQ (obj, Qnull_pointer)) return 1; */ /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ /* if (PURIFIED (XPNTR (obj))) return 1; */ if (XTYPE (obj) == Lisp_Type_Record) { struct lrecord_header *lheader = XRECORD_LHEADER (obj); GC_CHECK_LHEADER_INVARIANTS (lheader); return MARKED_RECORD_HEADER_P (lheader); } return 1; } /* Mark reference to a Lisp_Object. If the object referred to has not been seen yet, recursively mark all the references contained in it. */ void mark_object ( #ifdef USE_KKCC Lisp_Object UNUSED (obj) #else Lisp_Object obj #endif ) { #ifdef USE_KKCC /* this code should never be reached when configured for KKCC */ stderr_out ("KKCC: Invalid mark_object call.\n"); stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n"); ABORT (); #else /* not USE_KKCC */ tail_recurse: /* Checks we used to perform */ /* if (EQ (obj, Qnull_pointer)) return; */ /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ /* if (PURIFIED (XPNTR (obj))) return; */ if (XTYPE (obj) == Lisp_Type_Record) { struct lrecord_header *lheader = XRECORD_LHEADER (obj); GC_CHECK_LHEADER_INVARIANTS (lheader); /* We handle this separately, above, so we can mark free objects */ GC_CHECK_NOT_FREE (lheader); /* All c_readonly objects have their mark bit set, so that we only need to check the mark bit here. */ if (! MARKED_RECORD_HEADER_P (lheader)) { MARK_RECORD_HEADER (lheader); if (RECORD_MARKER (lheader)) { obj = RECORD_MARKER (lheader) (obj); if (!NILP (obj)) goto tail_recurse; } } } #endif /* not KKCC */ }  /************************************************************************/ /* Hooks */ /************************************************************************/ /* Nonzero when calling certain hooks or doing other things where a GC would be bad. It prevents infinite recursive calls to gc. */ int gc_currently_forbidden; int begin_gc_forbidden (void) { return internal_bind_int (&gc_currently_forbidden, 1); } void end_gc_forbidden (int count) { unbind_to (count); } /* Hooks. */ Lisp_Object Vpre_gc_hook, Qpre_gc_hook; Lisp_Object Vpost_gc_hook, Qpost_gc_hook; /* Maybe we want to use this when doing a "panic" gc after memory_full()? */ static int gc_hooks_inhibited; struct post_gc_action { void (*fun) (void *); void *arg; }; typedef struct post_gc_action post_gc_action; typedef struct { Dynarr_declare (post_gc_action); } post_gc_action_dynarr; static post_gc_action_dynarr *post_gc_actions; /* Register an action to be called at the end of GC. gc_in_progress is 0 when this is called. This is used when it is discovered that an action needs to be taken, but it's during GC, so it's not safe. (e.g. in a finalize method.) As a general rule, do not use Lisp objects here. And NEVER signal an error. */ void register_post_gc_action (void (*fun) (void *), void *arg) { post_gc_action action; if (!post_gc_actions) post_gc_actions = Dynarr_new (post_gc_action); action.fun = fun; action.arg = arg; Dynarr_add (post_gc_actions, action); } static void run_post_gc_actions (void) { int i; if (post_gc_actions) { for (i = 0; i < Dynarr_length (post_gc_actions); i++) { post_gc_action action = Dynarr_at (post_gc_actions, i); (action.fun) (action.arg); } Dynarr_reset (post_gc_actions); } }  /************************************************************************/ /* Garbage Collection */ /************************************************************************/ /* Enable/disable incremental garbage collection during runtime. */ int allow_incremental_gc; /* For profiling. */ static Lisp_Object QSin_garbage_collection; /* Nonzero means display messages at beginning and end of GC. */ int garbage_collection_messages; /* "Garbage collecting" */ Lisp_Object Vgc_message; Lisp_Object Vgc_pointer_glyph; static const Ascbyte gc_default_message[] = "Garbage collecting"; Lisp_Object Qgarbage_collecting; /* "Locals" during GC. */ struct frame *f; int speccount; int cursor_changed; Lisp_Object pre_gc_cursor; /* PROFILE_DECLARE */ int do_backtrace; struct backtrace backtrace; /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK #define MAX_SAVE_STACK 0 /* 16000 */ #endif void gc_prepare (void) { #if MAX_SAVE_STACK > 0 char stack_top_variable; extern char *stack_bottom; #endif #ifdef NEW_GC GC_STAT_START_NEW_GC; GC_SET_PHASE (INIT_GC); #endif /* NEW_GC */ do_backtrace = profiling_active || backtrace_with_internal_sections; assert (!gc_in_progress); assert (!in_display || gc_currently_forbidden); PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection); /* We used to call selected_frame() here. The following functions cannot be called inside GC so we move to after the above tests. */ { Lisp_Object frame; Lisp_Object device = Fselected_device (Qnil); if (NILP (device)) /* Could happen during startup, eg. if always_gc */ return; frame = Fselected_frame (device); if (NILP (frame)) invalid_state ("No frames exist on device", device); f = XFRAME (frame); } pre_gc_cursor = Qnil; cursor_changed = 0; need_to_signal_post_gc = 0; recompute_funcall_allocation_flag (); if (!gc_hooks_inhibited) run_hook_trapping_problems (Qgarbage_collecting, Qpre_gc_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); /* Now show the GC cursor/message. */ if (!noninteractive) { if (FRAME_WIN_P (f)) { Lisp_Object frame = wrap_frame (f); Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph, FRAME_SELECTED_WINDOW (f), ERROR_ME_NOT, 1); pre_gc_cursor = f->pointer; if (POINTER_IMAGE_INSTANCEP (cursor) /* don't change if we don't know how to change back. */ && POINTER_IMAGE_INSTANCEP (pre_gc_cursor)) { cursor_changed = 1; Fset_frame_pointer (frame, cursor); } } /* Don't print messages to the stream device. */ if (!cursor_changed && !FRAME_STREAM_P (f)) { if (garbage_collection_messages) { Lisp_Object args[2], whole_msg; args[0] = (STRINGP (Vgc_message) ? Vgc_message : build_msg_string (gc_default_message)); args[1] = build_string ("..."); whole_msg = Fconcat (2, args); echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1, Qgarbage_collecting); } } } /***** Now we actually start the garbage collection. */ gc_in_progress = 1; #ifndef NEW_GC inhibit_non_essential_conversion_operations = 1; #endif /* NEW_GC */ #if MAX_SAVE_STACK > 0 /* Save a copy of the contents of the stack, for debugging. */ if (!purify_flag) { /* Static buffer in which we save a copy of the C stack at each GC. */ static char *stack_copy; static Bytecount stack_copy_size; ptrdiff_t stack_diff = &stack_top_variable - stack_bottom; Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff); if (stack_size < MAX_SAVE_STACK) { if (stack_copy_size < stack_size) { stack_copy = (char *) xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } memcpy (stack_copy, stack_diff > 0 ? stack_bottom : &stack_top_variable, stack_size); } } #endif /* MAX_SAVE_STACK > 0 */ /* Do some totally ad-hoc resource clearing. */ /* #### generalize this? */ clear_event_resource (); cleanup_specifiers (); cleanup_buffer_undo_lists (); } void gc_mark_root_set ( #ifdef NEW_GC enum gc_phase phase #else /* not NEW_GC */ void #endif /* not NEW_GC */ ) { #ifdef NEW_GC GC_SET_PHASE (phase); #endif /* NEW_GC */ /* Mark all the special slots that serve as the roots of accessibility. */ #ifdef USE_KKCC # define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) #endif /* USE_KKCC */ { /* staticpro() */ Lisp_Object **p = Dynarr_begin (staticpros); Elemcount count; for (count = Dynarr_length (staticpros); count; count--) /* Need to check if the pointer in the staticpro array is not NULL. A gc can occur after variable is added to the staticpro array and _before_ it is correctly initialized. In this case its value is NULL, which we have to catch here. */ if (*p) mark_object (**p++); else **p++; } { /* staticpro_nodump() */ Lisp_Object **p = Dynarr_begin (staticpros_nodump); Elemcount count; for (count = Dynarr_length (staticpros_nodump); count; count--) /* Need to check if the pointer in the staticpro array is not NULL. A gc can occur after variable is added to the staticpro array and _before_ it is correctly initialized. In this case its value is NULL, which we have to catch here. */ if (*p) mark_object (**p++); else **p++; } #ifdef MC_ALLOC { /* mcpro () */ Lisp_Object *p = Dynarr_begin (mcpros); Elemcount count; for (count = Dynarr_length (mcpros); count; count--) mark_object (*p++); } #endif /* MC_ALLOC */ { /* GCPRO() */ struct gcpro *tail; int i; for (tail = gcprolist; tail; tail = tail->next) for (i = 0; i < tail->nvars; i++) mark_object (tail->var[i]); } { /* specbind() */ struct specbinding *bind; for (bind = specpdl; bind != specpdl_ptr; bind++) { mark_object (bind->symbol); mark_object (bind->old_value); } } { struct catchtag *c; for (c = catchlist; c; c = c->next) { mark_object (c->tag); mark_object (c->val); mark_object (c->actual_tag); mark_object (c->backtrace); } } { struct backtrace *backlist; for (backlist = backtrace_list; backlist; backlist = backlist->next) { int nargs = backlist->nargs; int i; mark_object (*backlist->function); if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */ /* might be fake (internal profiling entry) */ && backlist->args) mark_object (backlist->args[0]); else for (i = 0; i < nargs; i++) mark_object (backlist->args[i]); } } mark_profiling_info (); #ifdef USE_KKCC # undef mark_object #endif } void gc_finish_mark (void) { #ifdef NEW_GC GC_SET_PHASE (FINISH_MARK); #endif /* NEW_GC */ init_marking_ephemerons (); while (finish_marking_weak_hash_tables () > 0 || finish_marking_weak_lists () > 0 || continue_marking_ephemerons () > 0) #ifdef USE_KKCC { kkcc_marking (0); } #else /* not USE_KKCC */ ; #endif /* not USE_KKCC */ /* At this point, we know which objects need to be finalized: we still need to resurrect them */ while (finish_marking_ephemerons () > 0 || finish_marking_weak_lists () > 0 || finish_marking_weak_hash_tables () > 0) #ifdef USE_KKCC { kkcc_marking (0); } #else /* not USE_KKCC */ ; #endif /* not USE_KKCC */ /* And prune (this needs to be called after everything else has been marked and before we do any sweeping). */ /* #### this is somewhat ad-hoc and should probably be an object method */ prune_weak_hash_tables (); prune_weak_lists (); prune_specifiers (); prune_syntax_tables (); prune_ephemerons (); prune_weak_boxes (); } #ifdef NEW_GC void gc_finalize (void) { GC_SET_PHASE (FINALIZE); mc_finalize (); } void gc_sweep (void) { GC_SET_PHASE (SWEEP); mc_sweep (); } #endif /* NEW_GC */ void gc_finish (void) { #ifdef NEW_GC GC_SET_PHASE (FINISH_GC); #endif /* NEW_GC */ consing_since_gc = 0; #ifndef DEBUG_XEMACS /* Allow you to set it really fucking low if you really want ... */ if (gc_cons_threshold < 10000) gc_cons_threshold = 10000; #endif recompute_need_to_garbage_collect (); #ifndef NEW_GC inhibit_non_essential_conversion_operations = 0; #endif /* not NEW_GC */ gc_in_progress = 0; run_post_gc_actions (); /******* End of garbage collection ********/ /* Now remove the GC cursor/message */ if (!noninteractive) { if (cursor_changed) Fset_frame_pointer (wrap_frame (f), pre_gc_cursor); else if (!FRAME_STREAM_P (f)) { /* Show "...done" only if the echo area would otherwise be empty. */ if (NILP (clear_echo_area (selected_frame (), Qgarbage_collecting, 0))) { if (garbage_collection_messages) { Lisp_Object args[2], whole_msg; args[0] = (STRINGP (Vgc_message) ? Vgc_message : build_msg_string (gc_default_message)); args[1] = build_msg_string ("... done"); whole_msg = Fconcat (2, args); echo_area_message (selected_frame (), (Ibyte *) 0, whole_msg, 0, -1, Qgarbage_collecting); } } } } #ifndef MC_ALLOC if (!breathing_space) { breathing_space = malloc (4096 - MALLOC_OVERHEAD); } #endif /* not MC_ALLOC */ need_to_signal_post_gc = 1; funcall_allocation_flag = 1; PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); #ifdef NEW_GC GC_SET_PHASE (NONE); #endif /* NEW_GC */ } #ifdef NEW_GC void gc_suspend_mark_phase (void) { PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); write_barrier_enabled = 1; consing_since_gc = 0; vdb_start_dirty_bits_recording (); } int gc_resume_mark_phase (void) { PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection); assert (write_barrier_enabled); vdb_stop_dirty_bits_recording (); write_barrier_enabled = 0; return vdb_read_dirty_bits (); } int gc_mark (int incremental) { GC_SET_PHASE (MARK); if (!incremental) { kkcc_marking (0); } else { kkcc_marking (gc_incremental_traversal_threshold); if (!KKCC_GC_STACK_EMPTY) { gc_suspend_mark_phase (); return 0; } } return 1; } int gc_resume_mark (int incremental) { if (!incremental) { if (!KKCC_GC_STACK_EMPTY) { GC_STAT_RESUME_GC; /* An incremental garbage collection is already running --- now wrap it up and resume it atomically. */ gc_resume_mark_phase (); gc_mark_root_set (REPUSH_ROOT_SET); kkcc_marking (0); } } else { int repushed_objects; int mark_work; GC_STAT_RESUME_GC; repushed_objects = gc_resume_mark_phase (); mark_work = (gc_incremental_traversal_threshold > repushed_objects) ? gc_incremental_traversal_threshold : repushed_objects; kkcc_marking (mark_work); if (KKCC_GC_STACK_EMPTY) { /* Mark root set again and finish up marking. */ gc_mark_root_set (REPUSH_ROOT_SET); kkcc_marking (0); } else { gc_suspend_mark_phase (); return 0; } } return 1; } void gc_1 (int incremental) { switch (GC_PHASE) { case NONE: gc_prepare (); kkcc_gc_stack_init(); #ifdef DEBUG_XEMACS kkcc_bt_init (); #endif case INIT_GC: gc_mark_root_set (PUSH_ROOT_SET); case PUSH_ROOT_SET: if (!gc_mark (incremental)) return; /* suspend gc */ case MARK: if (!KKCC_GC_STACK_EMPTY) if (!gc_resume_mark (incremental)) return; /* suspend gc */ gc_finish_mark (); kkcc_gc_stack_free (); #ifdef DEBUG_XEMACS kkcc_bt_free (); #endif case FINISH_MARK: gc_finalize (); case FINALIZE: gc_sweep (); case SWEEP: gc_finish (); case FINISH_GC: break; } } void gc (int incremental) { if (gc_currently_forbidden || in_display || preparing_for_armageddon) return; /* Very important to prevent GC during any of the following stuff that might run Lisp code; otherwise, we'll likely have infinite GC recursion. */ speccount = begin_gc_forbidden (); gc_1 (incremental); /* now stop inhibiting GC */ unbind_to (speccount); } void gc_full (void) { gc (0); } DEFUN ("gc-full", Fgc_full, 0, 0, "", /* This function performs a full garbage collection. If an incremental garbage collection is already running, it completes without any further interruption. This function guarantees that unused objects are freed when it returns. Garbage collection happens automatically if the client allocates more than `gc-cons-threshold' bytes of Lisp data since the previous garbage collection. */ ()) { gc_full (); return Qt; } void gc_incremental (void) { gc (allow_incremental_gc); } DEFUN ("gc-incremental", Fgc_incremental, 0, 0, "", /* This function starts an incremental garbage collection. If an incremental garbage collection is already running, the next cycle starts. Note that this function has not necessarily freed any memory when it returns. This function only guarantees, that the traversal of the heap makes progress. The next cycle of incremental garbage collection happens automatically if the client allocates more than `gc-incremental-cons-threshold' bytes of Lisp data since previous garbage collection. */ ()) { gc_incremental (); return Qt; } #else /* not NEW_GC */ void garbage_collect_1 (void) { if (gc_in_progress || gc_currently_forbidden || in_display || preparing_for_armageddon) return; /* Very important to prevent GC during any of the following stuff that might run Lisp code; otherwise, we'll likely have infinite GC recursion. */ speccount = begin_gc_forbidden (); gc_prepare (); #ifdef USE_KKCC kkcc_gc_stack_init(); #ifdef DEBUG_XEMACS kkcc_bt_init (); #endif #endif /* USE_KKCC */ gc_mark_root_set (); #ifdef USE_KKCC kkcc_marking (0); #endif /* USE_KKCC */ gc_finish_mark (); #ifdef USE_KKCC kkcc_gc_stack_free (); #ifdef DEBUG_XEMACS kkcc_bt_free (); #endif #endif /* USE_KKCC */ gc_sweep_1 (); gc_finish (); /* now stop inhibiting GC */ unbind_to (speccount); } #endif /* not NEW_GC */  /************************************************************************/ /* Initializations */ /************************************************************************/ /* Initialization */ static void common_init_gc_early (void) { Vgc_message = Qzero; gc_currently_forbidden = 0; gc_hooks_inhibited = 0; need_to_garbage_collect = always_gc; gc_cons_threshold = GC_CONS_THRESHOLD; gc_cons_percentage = 40; /* #### what is optimal? */ total_gc_usage_set = 0; #ifdef NEW_GC gc_cons_incremental_threshold = GC_CONS_INCREMENTAL_THRESHOLD; gc_incremental_traversal_threshold = GC_INCREMENTAL_TRAVERSAL_THRESHOLD; #endif /* not NEW_GC */ } void init_gc_early (void) { } void reinit_gc_early (void) { common_init_gc_early (); } void init_gc_once_early (void) { common_init_gc_early (); } void syms_of_gc (void) { DEFSYMBOL (Qpre_gc_hook); DEFSYMBOL (Qpost_gc_hook); #ifdef NEW_GC DEFSUBR (Fgc_full); DEFSUBR (Fgc_incremental); #ifdef ERROR_CHECK_GC DEFSUBR (Fgc_stats); #endif /* not ERROR_CHECK_GC */ #endif /* NEW_GC */ } void vars_of_gc (void) { staticpro_nodump (&pre_gc_cursor); QSin_garbage_collection = build_msg_string ("(in garbage collection)"); staticpro (&QSin_garbage_collection); DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /* *Number of bytes of consing between full garbage collections. \"Consing\" is a misnomer in that this actually counts allocation of all different kinds of objects, not just conses. Garbage collection can happen automatically once this many bytes have been allocated since the last garbage collection. All data types count. Garbage collection happens automatically when `eval' or `funcall' are called. (Note that `funcall' is called implicitly as part of evaluation.) By binding this temporarily to a large number, you can effectively prevent garbage collection during a part of the program. Normally, you cannot set this value less than 10,000 (if you do, it is automatically reset during the next garbage collection). However, if XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing you to set this value very low to track down problems with insufficient GCPRO'ing. If you set this to a negative number, garbage collection will happen at *EVERY* call to `eval' or `funcall'. This is an extremely effective way to check GCPRO problems, but be warned that your XEmacs will be unusable! You almost certainly won't have the patience to wait long enough to be able to set it back. See also `consing-since-gc' and `gc-cons-percentage'. */ ); DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /* *Percentage of memory allocated between garbage collections. Garbage collection will happen if this percentage of the total amount of memory used for data (see `lisp-object-memory-usage') has been allocated since the last garbage collection. However, it will not happen if less than `gc-cons-threshold' bytes have been allocated -- this sets an absolute minimum in case very little data has been allocated or the percentage is set very low. Set this to 0 to have garbage collection always happen after `gc-cons-threshold' bytes have been allocated, regardless of current memory usage. See also `consing-since-gc' and `gc-cons-threshold'. */ ); #ifdef NEW_GC DEFVAR_INT ("gc-cons-incremental-threshold", &gc_cons_incremental_threshold /* *Number of bytes of consing between cycles of incremental garbage collections. \"Consing\" is a misnomer in that this actually counts allocation of all different kinds of objects, not just conses. The next garbage collection cycle can happen automatically once this many bytes have been allocated since the last garbage collection cycle. All data types count. See also `gc-cons-threshold'. */ ); DEFVAR_INT ("gc-incremental-traversal-threshold", &gc_incremental_traversal_threshold /* *Number of elements processed in one cycle of incremental travesal. */ ); #endif /* NEW_GC */ DEFVAR_BOOL ("purify-flag", &purify_flag /* Non-nil means loading Lisp code in order to dump an executable. This means that certain objects should be allocated in readonly space. */ ); DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /* Non-nil means display messages at start and end of garbage collection. */ ); garbage_collection_messages = 0; DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /* Function or functions to be run just before each garbage collection. Interrupts, garbage collection, and errors are inhibited while this hook runs, so be extremely careful in what you add here. In particular, avoid consing, and do not interact with the user. */ ); Vpre_gc_hook = Qnil; DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /* Function or functions to be run just after each garbage collection. Interrupts, garbage collection, and errors are inhibited while this hook runs. Each hook is called with one argument which is an alist with finalization data. */ ); Vpost_gc_hook = Qnil; DEFVAR_LISP ("gc-message", &Vgc_message /* String to print to indicate that a garbage collection is in progress. This is printed in the echo area. If the selected frame is on a window system and `gc-pointer-glyph' specifies a value (i.e. a pointer image instance) in the domain of the selected frame, the mouse pointer will change instead of this message being printed. */ ); Vgc_message = build_string (gc_default_message); DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* Pointer glyph used to indicate that a garbage collection is in progress. If the selected window is on a window system and this glyph specifies a value (i.e. a pointer image instance) in the domain of the selected window, the pointer will be changed as specified during garbage collection. Otherwise, a message will be printed in the echo area, as controlled by `gc-message'. */ ); #ifdef NEW_GC DEFVAR_BOOL ("allow-incremental-gc", &allow_incremental_gc /* *Non-nil means to allow incremental garbage collection. Nil prevents *incremental garbage collection, the garbage collector then only does *full collects (even if (gc-incremental) is called). */ ); #endif /* NEW_GC */ } void complex_vars_of_gc (void) { Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); } 1.1 XEmacs/xemacs/src/gc.h Index: gc.h =================================================================== /* New incremental garbage collector for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #ifndef INCLUDED_gc_h_ #define INCLUDED_gc_h_ BEGIN_C_DECLS  #ifdef NEW_GC /************************************************************************/ /* Incremental Statistics */ /************************************************************************/ #ifdef ERROR_CHECK_GC void gc_stat_print_stats (void); void gc_stat_finalized (void); void gc_stat_freed (void); void gc_stat_explicitly_freed (void); void gc_stat_explicitly_tried_freed (void); # define GC_STAT_FINALIZED gc_stat_finalized () # define GC_STAT_FREED gc_stat_freed () # define GC_STAT_EXPLICITLY_FREED gc_stat_explicitly_freed () # define GC_STAT_EXPLICITLY_TRIED_FREED gc_stat_explicitly_tried_freed () #else /* not ERROR_CHECK_GC */ # define GC_STAT_FINALIZED # define GC_STAT_FREED # define GC_STAT_EXPLICITLY_FREED # define GC_STAT_EXPLICITLY_TRIED_FREED #endif /* not ERROR_CHECK_GC */ #endif /* not NEW_GC */  /************************************************************************/ /* Global Variables */ /************************************************************************/ /* Number of bytes of consing done since the last GC. */ extern EMACS_INT consing_since_gc; /* Number of bytes of consing done since startup. */ extern EMACS_UINT total_consing; /* Number of bytes of current allocated heap objects. */ extern EMACS_INT total_gc_usage; /* If the above is set. */ extern int total_gc_usage_set; /* Number of bytes of consing since gc before another gc should be done. */ extern EMACS_INT gc_cons_threshold; /* Percentage of consing of total data size before another GC. */ extern EMACS_INT gc_cons_percentage; #ifdef NEW_GC /* Number of bytes of consing since gc before another cycle of the gc should be done in incremental mode. */ extern EMACS_INT gc_cons_incremental_threshold; /* Nonzero during gc */ extern int gc_in_progress; /* Nonzero during write barrier */ extern int write_barrier_enabled; /* Enable/disable incremental garbage collection during runtime. */ extern int allow_incremental_gc; #endif /* NEW_GC */  /************************************************************************/ /* Prototypes */ /************************************************************************/ #ifndef MALLOC_OVERHEAD #ifdef GNU_MALLOC #define MALLOC_OVERHEAD 0 #elif defined (rcheck) #define MALLOC_OVERHEAD 20 #else #define MALLOC_OVERHEAD 8 #endif #endif /* MALLOC_OVERHEAD */ #ifdef ERROR_CHECK_GC #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ struct lrecord_header * GCLI_lh = (lheader); \ assert (GCLI_lh != 0); \ assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ } while (0) #else #define GC_CHECK_LHEADER_INVARIANTS(lheader) #endif void recompute_need_to_garbage_collect (void); /* KKCC mark algorithm. */ #ifdef DEBUG_XEMACS void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos); #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) void kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj, int level, int pos); #define kkcc_gc_stack_repush_dirty_object(obj) \ kkcc_gc_stack_repush_dirty_object_1 (obj, 0, -2) void kkcc_backtrace (void); #else void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj); #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ kkcc_gc_stack_push_lisp_object_1 (obj) void kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj); #define kkcc_gc_stack_repush_dirty_object(obj) \ kkcc_gc_stack_repush_dirty_object_1 (obj) #define kkcc_backtrace() #endif #ifdef NEW_GC /* Repush objects that are caught by the write barrier. */ #define gc_write_barrier(obj) kkcc_gc_stack_repush_dirty_object (obj); /* GC functions: */ /* Perform a full garbage collection without interruption. If an incremental garbage collection is already running it is completed without further interruption. This function calls gc() with a negative or zero argument. */ void gc_full (void); /* This function starts an incremental garbage collection. If an incremental garbage collection is already running, the next cycle of traversal work is done, or the garbage collection is completed when no more traversal work has to be done. This function calls gc with a positive argument, indicating how many objects can be traversed in this cycle. */ void gc_incremental (void); #endif /* NEW_GC */ /* Initializers */ void init_gc_early (void); void reinit_gc_early (void); void init_gc_once_early (void); void syms_of_gc (void); void vars_of_gc (void); void complex_vars_of_gc (void); #ifndef NEW_GC /* Needed prototypes due to the garbage collector code move from alloc.c to gc.c. */ void gc_sweep_1 (void); #ifndef MC_ALLOC extern void *breathing_space; #endif /* not MC_ALLOC */ #endif /* not NEW_GC */ END_C_DECLS #endif /* INCLUDED_gc_h_ */ 1.1 XEmacs/xemacs/src/vdb-fake.c Index: vdb-fake.c =================================================================== /* Virtual diry bit implementation for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" void fake_error (void) { fprintf (stderr, "Incremental garbage collection not yet available on this"); fprintf (stderr, "system.\nDon't try to set allow-incremental-gc to t.\n"); ABORT (); } void vdb_install_signal_handler (void) { allow_incremental_gc = 0; } void vdb_protect (void *UNUSED (ptr), EMACS_INT UNUSED (len)) { fake_error (); } void vdb_unprotect (void *UNUSED (ptr), EMACS_INT UNUSED (len)) { fake_error (); } 1.1 XEmacs/xemacs/src/vdb-mach.c Index: vdb-mach.c =================================================================== /* Virtual diry bit implementation for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" #include "gc.h" #include "mc-alloc.h" #include "vdb.h" #include <errno.h> #include <signal.h> #include <sys/mman.h> #include <sys/time.h> #include <sys/resource.h> #include <unistd.h> #include <mach/mach.h> #include <mach/mach_error.h> #include <architecture/ppc/cframe.h> /* the structure of an exception msg and its reply */ typedef struct rep_msg { mach_msg_header_t head; NDR_record_t NDR; kern_return_t ret_code; } mach_reply_msg_t; typedef struct exc_msg { mach_msg_header_t head; /* start of the kernel processed data */ mach_msg_body_t msgh_body; mach_msg_port_descriptor_t thread; mach_msg_port_descriptor_t task; /* end of the kernel processed data */ NDR_record_t NDR; exception_type_t exception; mach_msg_type_number_t code_cnt; exception_data_t code; /* some padding */ char pad[512]; } mach_exc_msg_t; /* this is a neat little mach callback */ extern boolean_t exc_server(mach_msg_header_t *in, mach_msg_header_t *out); /* these are the globals everyone needs */ static size_t page_size = 16384; static mach_port_t task_self = NULL; static mach_port_t exc_port = NULL; /* these are some less neat mach callbacks */ kern_return_t catch_exception_raise_state (mach_port_t UNUSED (port), exception_type_t UNUSED (exception_type), exception_data_t UNUSED (exception_data), mach_msg_type_number_t UNUSED (data_cnt), thread_state_flavor_t *UNUSED (flavor), thread_state_t UNUSED (in_state), mach_msg_type_number_t UNUSED (is_cnt), thread_state_t UNUSED (out_state), mach_msg_type_number_t UNUSED (os_cnt)) { return KERN_FAILURE; } kern_return_t catch_exception_raise_state_identitity (mach_port_t UNUSED (port), mach_port_t UNUSED (thread_port), mach_port_t UNUSED (task_port), exception_type_t UNUSED (exception_type), exception_data_t UNUSED (exception_data), mach_msg_type_number_t UNUSED (data_count), thread_state_flavor_t *UNUSED (state_flavor), thread_state_t UNUSED (in_state), mach_msg_type_number_t UNUSED (in_state_count), thread_state_t UNUSED (out_state), mach_msg_type_number_t UNUSED (out_state_count)) { return KERN_FAILURE; } kern_return_t catch_exception_raise (mach_port_t UNUSED (port), mach_port_t UNUSED (thread_port), mach_port_t UNUSED (task_port), exception_type_t UNUSED (exception_type), exception_data_t exception_data, mach_msg_type_number_t UNUSED (data_count)) { /* kernel return value is in exception_data[0], faulting address in exception_data[1] */ if (write_barrier_enabled && (fault_on_protected_page ((void *) exception_data[1])) && exception_data[0] == KERN_PROTECTION_FAILURE) { vdb_designate_modified ((void *) exception_data[1]); unprotect_page_and_mark_dirty ((void *) exception_data[1]); return KERN_SUCCESS; } else /* default sigsegv handler */ { fprintf (stderr, "\n\nFatal Error: Received %s (%d) for address 0x%x\n", "EXC_BAD_ACCESS", exception_data[0], (int) exception_data[1]); return KERN_FAILURE; } } /* this is the thread which forwards of exceptions read from the exception server off to our exception catchers and then back out to the other thread */ void exception_thread(void) { mach_msg_header_t *message; mach_msg_header_t *reply; kern_return_t retval; /* allocate the space for the message and reply */ message = (mach_msg_header_t *) malloc (sizeof (mach_exc_msg_t)); reply = (mach_msg_header_t *) malloc (sizeof (mach_reply_msg_t)); /* do this loop forever */ while (1) { /* block until we get an exception message */ retval = mach_msg (message, MACH_RCV_MSG, 0, sizeof (mach_exc_msg_t), exc_port, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); /* forward off the handling of this message */ if (!exc_server (message, reply)) { fprintf (stderr, "INTERNAL ERROR: exc_server() failed.\n"); ABORT (); } /* send the message back out to the thread */ retval = mach_msg (reply, MACH_SEND_MSG, sizeof (mach_reply_msg_t), 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL); } } /* this initializes the subsystem (sets the exception port, starts the exception handling thread, etc) */ void vdb_install_signal_handler (void) { mach_port_t thread_self, exc_port_s, exc_thread; ppc_thread_state_t *exc_thread_state; mach_msg_type_name_t type; void *subthread_stack; kern_return_t retval; /* get ids for ourself */ if (!task_self) task_self = mach_task_self (); thread_self = mach_thread_self (); /* allocate the port we're going to get exceptions on */ retval = mach_port_allocate (task_self, MACH_PORT_RIGHT_RECEIVE, &exc_port); if (retval != KERN_SUCCESS) { fprintf (stderr, "Couldn't allocate exception port: %s\n", mach_error_string (retval)); ABORT (); } /* extract out the send rights for that port, which the OS needs */ retval = mach_port_extract_right (task_self, exc_port, MACH_MSG_TYPE_MAKE_SEND, &exc_port_s, &type); if(retval != KERN_SUCCESS) { fprintf (stderr, "Couldn't extract send rights: %s\n", mach_error_string (retval)); ABORT (); } /* set the exception ports for this thread to the above */ retval = thread_set_exception_ports(thread_self, EXC_MASK_BAD_ACCESS, exc_port_s, EXCEPTION_DEFAULT, PPC_THREAD_STATE); if(retval != KERN_SUCCESS) { fprintf (stderr, "Couldn't set exception ports: %s\n", mach_error_string (retval)); ABORT (); } /* set up the subthread */ retval = thread_create(task_self, &exc_thread); if(retval != KERN_SUCCESS) { fprintf (stderr , "Couldn't create exception thread: %s\n", mach_error_string (retval)); ABORT (); } subthread_stack = (void *) malloc (page_size); subthread_stack = (char *) subthread_stack + (page_size - C_ARGSAVE_LEN - C_RED_ZONE); exc_thread_state = (ppc_thread_state_t *) malloc (sizeof (ppc_thread_state_t)); exc_thread_state->srr0 = (unsigned int) exception_thread; exc_thread_state->r1 = (unsigned int) subthread_stack; retval = thread_set_state (exc_thread, PPC_THREAD_STATE, (thread_state_t) exc_thread_state, PPC_THREAD_STATE_COUNT); if (retval != KERN_SUCCESS) { fprintf (stderr, "Couldn't set subthread state: %s\n", mach_error_string (retval)); ABORT (); } retval = thread_resume (exc_thread); if (retval != KERN_SUCCESS) { fprintf (stderr, "Couldn't resume subthread: %s\n", mach_error_string (retval)); ABORT (); } allow_incremental_gc = 1; } void vdb_protect (void *ptr, EMACS_INT len) { if (mprotect (ptr, len, PROT_READ)) { perror ("Couldn't mprotect"); ABORT (); } } void vdb_unprotect (void *ptr, EMACS_INT len) { if (mprotect (ptr, len, PROT_READ | PROT_WRITE)) { perror ("Couldn't mprotect"); ABORT (); } } 1.1 XEmacs/xemacs/src/vdb-posix.c Index: vdb-posix.c =================================================================== /* Virtual diry bit implementation for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" #include "gc.h" #include "mc-alloc.h" #include "vdb.h" #include <errno.h> #include <signal.h> #include <sys/mman.h> #if defined (HAVE_SIGACTION) # if defined (HAVE_STRUCT_SIGINFO_SI_ADDR) # define FAULT_HANDLER_ARGUMENTS \ int signum, struct siginfo *siginfo, void *UNUSED (ctx) # define GET_FAULT_ADDRESS siginfo->si_addr # elif defined (HAVE_SIGINFO_T_SI_ADDR) # define FAULT_HANDLER_ARGUMENTS \ int signum, siginfo_t *siginfo, void *UNUSED (ctx) # define GET_FAULT_ADDRESS siginfo->si_addr # endif # define USE_SIGACTION # define FAULT_HANDLER_REMOVE_HANDLER #elif defined (HAVE_SIGNAL) # define FAULT_HANDLER_ARGUMENTS int signum, struct sigcontext sc # define GET_FAULT_ADDRESS (void *) sc.cr2 # define USE_SIGNAL #endif #ifdef USE_SIGACTION struct sigaction act, segv_oact, bus_oact; #endif /* USE_SIGACTION */ #ifdef USE_SIGNAL sighandler_t segv_oact, bus_oact; #endif /* USE_SIGNAL */ void vdb_remove_signal_handler (void); void vdb_fault_handler (FAULT_HANDLER_ARGUMENTS) { if (write_barrier_enabled && (fault_on_protected_page (GET_FAULT_ADDRESS))) { vdb_designate_modified (GET_FAULT_ADDRESS); unprotect_page_and_mark_dirty (GET_FAULT_ADDRESS); #ifdef FAULT_HANDLER_REINSTALL_HANDLER vdb_install_signal_handler (); #endif /* FAULT_HANDLER_REINSTALL_HANDLER */ } else /* default sigsegv handler */ { char *signal_name; if (signum == SIGSEGV) signal_name = "SIGSEGV"; else if (signum == SIGBUS) signal_name = "SIGBUS"; else ABORT (); /* something weird happened: wrong signal caught */ fprintf (stderr, "\n\nFatal Error: Received %s (%d) for address 0x%x\n", signal_name, signum, (int) GET_FAULT_ADDRESS); #ifdef FAULT_HANDLER_CALL_PREVIOUS_HANDLER if (signum == SIGSEGV) segv_oact (signum); else if (signum == SIGBUS) bus_oact (signum); #endif /* FAULT_HANDLER_CALL_PREVIOUS_HANDLER */ #ifdef FAULT_HANDLER_REMOVE_HANDLER vdb_remove_signal_handler (); #endif /* FAULT_HANDLER_REMOVE_HANDLER */ } } void vdb_remove_signal_handler (void) { #ifdef USE_SIGACTION sigaction(SIGSEGV, &segv_oact, 0); sigaction(SIGBUS, &bus_oact, 0); #endif /* USE_SIGACTION */ #ifdef USE_SIGNAL signal (SIGSEGV, segv_oact); signal (SIGBUS, bus_oact); #endif } void vdb_install_signal_handler (void) { /* See init_signals_very_early () in signal.c. */ if (noninteractive && !initialized) { allow_incremental_gc = 0; return; } #ifdef USE_SIGACTION memset(&act, sizeof(struct sigaction), 0); act.sa_sigaction = vdb_fault_handler; sigemptyset (&act.sa_mask); act.sa_flags = SA_SIGINFO; sigaction (SIGSEGV, &act, &segv_oact); sigaction (SIGBUS, &act, &bus_oact); allow_incremental_gc = 1; #endif /* USE_SIGACTION */ #ifdef USE_SIGNAL segv_oact = signal (SIGSEGV, (void (*)(int)) vdb_fault_handler); bus_oact = signal (SIGBUS, (void (*)(int)) vdb_fault_handler); #endif /* USE_SIGNAL */ } void vdb_protect (void *ptr, EMACS_INT len) { if (mprotect (ptr, len, PROT_READ)) { perror ("Couldn't mprotect"); ABORT (); } } void vdb_unprotect (void *ptr, EMACS_INT len) { if (mprotect (ptr, len, PROT_READ | PROT_WRITE)) { perror ("Couldn't mprotect"); ABORT (); } } 1.1 XEmacs/xemacs/src/vdb-win32.c Index: vdb-win32.c =================================================================== /* Virtual diry bit implementation for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" #include "gc.h" #include "mc-alloc.h" #include "vdb.h" #include "syswindows.h" DWORD WINAPI win32_fault_handler (LPEXCEPTION_POINTERS e) { #define GET_FAULT_ADDRESS (void *) e->ExceptionRecord->ExceptionInformation[1] if ((e->ExceptionRecord->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) && (e->ExceptionRecord->ExceptionInformation[0] == 1) && write_barrier_enabled && (fault_on_protected_page (GET_FAULT_ADDRESS))) { vdb_designate_modified (GET_FAULT_ADDRESS); unprotect_page_and_mark_dirty (GET_FAULT_ADDRESS); return EXCEPTION_CONTINUE_EXECUTION; } else return EXCEPTION_CONTINUE_SEARCH; } typedef DWORD (WINAPI *gcPVECTORED_EXCEPTION_HANDLER) (LPEXCEPTION_POINTERS e); void vdb_install_signal_handler (void) { HMODULE hm; PVOID (WINAPI *aveh) (ULONG, gcPVECTORED_EXCEPTION_HANDLER); /* See init_signals_very_early () in signal.c. */ if (noninteractive && !initialized) { allow_incremental_gc = 0; return; } hm = qxeGetModuleHandle (XETEXT ("kernel32")); if (hm) aveh = (PVOID (WINAPI *) (ULONG, gcPVECTORED_EXCEPTION_HANDLER)) GetProcAddress (hm, "AddVectoredExceptionHandler"); else { fprintf (stderr, "\nFAILED TO LOAD LIBRARY\n"); aveh = NULL; } if (aveh) { allow_incremental_gc = 1; aveh (TRUE, win32_fault_handler); } else { fprintf (stderr, "\nFAILED TO INSTALL SIGNAL HANDLER\n"); ABORT (); } } void vdb_protect (void *ptr, EMACS_INT len) { DWORD old; VirtualProtect (ptr, len, PAGE_READONLY, &old); } void vdb_unprotect (void *ptr, EMACS_INT len) { DWORD old; VirtualProtect (ptr, len, PAGE_READWRITE, &old); } 1.1 XEmacs/xemacs/src/vdb.c Index: vdb.c =================================================================== /* Virtual diry bit implementation (platform independent) for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include <config.h> #include "lisp.h" #include "gc.h" #include "mc-alloc.h" #include "vdb.h" typedef struct { Dynarr_declare (void *); } void_ptr_dynarr; void_ptr_dynarr *page_fault_table; /* Init page fault table and protect heap. */ void vdb_start_dirty_bits_recording (void) { page_fault_table = Dynarr_new2 (void_ptr_dynarr, void *); protect_heap_pages (); } /* Remove heap protection. */ void vdb_stop_dirty_bits_recording (void) { unprotect_heap_pages (); } /* Read page fault table and pass page faults to garbage collector. */ int vdb_read_dirty_bits (void) { int repushed_objects = 0; Elemcount count; for (count = Dynarr_length (page_fault_table); count; count--) repushed_objects += repush_all_objects_on_page (Dynarr_at (page_fault_table, count - 1)); Dynarr_free (page_fault_table); page_fault_table = 0; return repushed_objects; } /* Called by the page fault handler: add address to page fault table. */ void vdb_designate_modified (void *addr) { Dynarr_add (page_fault_table, addr); } /* For testing and debugging... */ DEFUN ("test-vdb", Ftest_vdb, 0, 0, "", /* Test virtual dirty bit implementation. Prints results to stderr. */ ()) { Rawbyte *p; char c; Elemcount count; /* Wrap up gc (if currently running). */ gc_full (); /* Allocate a buffer; it will have the default protection of PROT_READ|PROT_WRITE. */ p = (Rawbyte *) mc_alloc (mc_get_page_size()); set_lheader_implementation ((struct lrecord_header *) p, &lrecord_cons); fprintf (stderr, "Allocate p: [%x ... %x], length %d\n", (int) p, (int) (p + mc_get_page_size ()), (int) mc_get_page_size ()); /* Test read. */ fprintf (stderr, "Attempt to read p[666]... "); c = p[666]; fprintf (stderr, "read ok.\n"); /* Test write. */ fprintf (stderr, "Attempt to write 42 to p[666]... "); p[666] = 42; fprintf (stderr, "write ok, p[666] = %d\n", p[666]); /* Mark the buffer read-only and set environemnt for write-barrier. */ fprintf (stderr, "Write-protect the page.\n"); MARK_BLACK (p); vdb_start_dirty_bits_recording (); write_barrier_enabled = 1; /* Test write-barrier read. */ fprintf (stderr, "Attempt to read p[666]... "); c = p[666]; fprintf (stderr, "read ok.\n"); /* Test write-barrier write, program receives SIGSEGV. */ fprintf (stderr, "Attempt to write 23 to p[666]... "); p[666] = 23; fprintf (stderr, "Written p[666] = %d\n", p[666]); /* Stop write-barrier mode. */ write_barrier_enabled = 0; MARK_WHITE (p); vdb_unprotect (p, mc_get_page_size ()); for (count = Dynarr_length (page_fault_table); count; count--) if (Dynarr_at (page_fault_table, count - 1) == &p[666]) fprintf (stderr, "VALID page fault at %x\n", (int) Dynarr_at (page_fault_table, count - 1)); else fprintf (stderr, "WRONG page fault at %x\n", (int) Dynarr_at (page_fault_table, count - 1)); Dynarr_free (page_fault_table); mc_free (p); return Qnil; } DEFUN ("test-segfault", Ftest_segfault, 0, 0, "", /* Test virtual dirty bit implementation: provoke a segfault on purpose. WARNING: this function causes a SEGFAULT on purpose and thus crashes XEmacs! This is only used for debbugging, e.g. for testing how the debugger behaves when XEmacs segfaults and the write barrier is enabled. */ ()) { Rawbyte *q = 0; q[0] = 23; return Qnil; } void syms_of_vdb (void) { DEFSUBR (Ftest_vdb); DEFSUBR (Ftest_segfault); } 1.1 XEmacs/xemacs/src/vdb.h Index: vdb.h =================================================================== /* Virtual diry bit implementation for XEmacs. Copyright (C) 2005 Marcus Crestani. This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with XEmacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ #include "lisp.h" #ifndef INCLUDED_vdb_h_ #define INCLUDED_vdb_h_ /*--- prototypes -------------------------------------------------------*/ BEGIN_C_DECLS /* Platform dependent signal handling: */ /* Install the platform-dependent signal handler. */ void vdb_install_signal_handler (void); /* Platform dependent memory protection. */ void vdb_protect (void *ptr, EMACS_INT len); void vdb_unprotect (void *ptr, EMACS_INT len); /* Common (platform independent) virtual diry bit stuff: */ /* Start the write barrier. This function is called when a garbage collection is suspendend and the client is resumed. */ void vdb_start_dirty_bits_recording (void); /* Stop the write barrier. This function is called when the client is suspendend and garbage collection is resumed. */ void vdb_stop_dirty_bits_recording (void); /* Record page faults: Add the object pointed to by addr to the write barrer's internal data structure that stores modified objects. This function is called by the write barrier's fault handler. */ void vdb_designate_modified (void *addr); /* Propagate page faults to garbage collector: Read out the write barrier's internal data structure that stores modified objects and pass the information to the garbage collector. This function is called by vdb_stop_dirty_bits_recording(). Return how many objects have to be re-examined by the garbage collector. */ int vdb_read_dirty_bits (void); /* Provides Lisp functions for testing vdb implementation. */ void syms_of_vdb (void); END_C_DECLS #endif /* INCLUDED_vdb_h_ */