XEmacs-Patches November 2005

xemacs-patches@xemacs.org

29 participants
111 discussions

[COMMIT] Fix pixel-to-point conversion arithmetic in font.el 18 years, 4 months

Aidan Kehoe

APPROVE COMMIT 21.5 NOTE: This patch has been committed. This should be considered for 21.4, Vin. lisp/ChangeLog addition: 2005-03-25 Ralf Angeli <angeli(a)iwi.uni-sb.de> * font.el (font-spatial-to-canonical): Correct calculation of return value for pixel-based input value. XEmacs Trunk source patch: Diff command: cvs -q diff -u Files affected: lisp/font.el Index: lisp/font.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/font.el,v retrieving revision 1.16 diff -u -u -r1.16 font.el --- lisp/font.el 2005/01/28 02:58:40 1.16 +++ lisp/font.el 2005/03/25 15:56:05 ＠＠ -311,8 +311,8 ＠＠ a number, it is interpreted as the desired point size and returned unchanged. Otherwise SPEC must be a string consisting of a number and an optional type. The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or -\"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), \"cm\" -(centimeters), or \"mm\" (millimeters). +\"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), +\"cm\" (centimeters), or \"mm\" (millimeters). 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent." (cond ＠＠ -351,7 +351,7 ＠＠ (setq num (string-to-number spec)) (cond ((member type '("pixel" "px" "pix")) - (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0)))) + (setq retval (* num (/ mm-width pix-width) (/ 72.0 25.4)))) ((member type '("point" "pt")) (setq retval num)) ((member type '("pica" "pa")) -- “I, for instance, am gung-ho about open source because my family is being held hostage in Rob Malda’s basement. But who fact-checks me, or Enderle, when we say something in public? No-one!” -- Danny O’Brien

3 participants
2 comments

[AC21.5R21.4] Stop geometry thrashing in tabs widget 18 years, 4 months

Stephen J. Turnbull

APPROVE COMMIT 21.5 RECOMMEND 21.4 Vin: applies with offset +5 and fuzz 1 on hunk 3. Not yet tested in 21.4. If you put a printf in xlwtabs.c (TabsGeometryManager) immediately _after_ the test for "position changed or not resizable" at the top of the function, you should see that without the patch the printf spews output on every window, frame, or buffer change; with the patch, you should _never_ see it. It turns out that the tabs widget has two parts: the row of tabs, and the children that it controls. In XEmacs, the children are irrelevant and never displayed; they're only used for their label/name resources. (What a waste, but never mind....) So there's no point in doing any geometry negotiation with them ever. The existing code attempts to set the XtNresizable resource to NULL, but does so on the _parent_ widget which doesn't actually have such a resource, not on the individual children. This patch fixes that. Index: lwlib/ChangeLog =================================================================== RCS file: /Users/steve/Software/Repositories/cvs.xemacs.org/XEmacs/xemacs/lwlib/ChangeLog,v retrieving revision 1.65 diff -u -r1.65 ChangeLog --- lwlib/ChangeLog 18 Feb 2005 06:29:19 -0000 1.65 +++ lwlib/ChangeLog 8 Mar 2005 15:06:21 -0000 ＠＠ -0,0 +1,6 ＠＠ +2005-03-07 Stephen J. Turnbull <stephen(a)xemacs.org> + + * lwlib-Xlw.c (build_tabs_in_widget): Correctly disable geometry + negotiation for tab children. + (xlw_create_tab_control): Don't set nonexistent resizable resource. + Index: lwlib/lwlib-Xlw.c =================================================================== RCS file: /Users/steve/Software/Repositories/cvs.xemacs.org/XEmacs/xemacs/lwlib/lwlib-Xlw.c,v retrieving revision 1.13 diff -u -r1.13 lwlib-Xlw.c --- lwlib/lwlib-Xlw.c 20 Sep 2004 19:19:16 -0000 1.13 +++ lwlib/lwlib-Xlw.c 9 Mar 2005 01:00:58 -0000 ＠＠ -319,13 +319,21 ＠＠ #ifdef LWLIB_TABS_LUCID /* tab control - lwlib is such an incredible hairy crock. I just cannot believe + [[ lwlib is such an incredible hairy crock. I just cannot believe it! There are random dependencies between functions, there is a total lack of genericity, even though it initially appears to be generic. It should all be junked and begun again. Building tabs are an example - in theory we should be able to reuse a lot of the general stuff because we want to put labels of whatever toolkit we - are using in the tab. Instead we have to hack it by hand. */ + are using in the tab. Instead we have to hack it by hand. ]] + While lwlib is a hairy crock, whoever wrote that seems to misunderstand + Falk's tab control widget. The tab control widget has *two* kinds of + children: *widgets*, which all occupy a *single* pane below the row of + tabs---this is where the labels created in build_tabs_in_widget go, and + *gadgets*, the tabs themselves, which do *not* draw themselves, but + rather are drawn by the control. In fact, in XEmacs the true widget + children are *never* visible! So this case is not a problem in the + design of lwlib, but rather of Falk's widget. -- sjt */ static void xlw_tab_control_callback (Widget w, XtPointer client_data, XtPointer call_data) { ＠＠ -375,9 +383,8 ＠＠ widget_value* val = instance->info->val; XtSetArg (al [ac], XtNsensitive, val->enabled); ac++; - XtSetArg (al [ac], XtNmappedWhenManaged, FALSE); ac++; + XtSetArg (al [ac], XtNmappedWhenManaged, False); ac++; XtSetArg (al [ac], XtNorientation, XtorientHorizontal); ac++; - XtSetArg (al [ac], XtNresizable, False); ac++; /* add any args the user supplied for creation time */ lw_add_value_args_to_args (val, al, &ac); ＠＠ -396,15 +403,22 ＠＠ Widget widget, widget_value* val) { widget_value* cur = val; + Arg al[1]; + + /* Children are always invisible, don't permit resizing. */ + XtSetArg (al[0], XtNresizable, False); + for (cur = val; cur; cur = cur->next) { if (cur->value) { + Widget w; #ifdef LWLIB_WIDGETS_MOTIF - xm_create_label (widget, cur); + w = xm_create_label (widget, cur); #else - xaw_create_label (widget, cur); + w = xaw_create_label (widget, cur); #endif + XtSetValues (w, al, 1); } cur->change = NO_CHANGE; } -- Institute of Policy and Planning Sciences http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software.

2 participants
1 comments

[R21.4] document CCL example 18 years, 4 months

Stephen J. Turnbull

RECOMMEND 21.4 Vin: this is actually work by Aidan that I found on the floor. I'm sure Aidan recommends it, too. :-) This patch is against 21.4. Index: man/ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/man/ChangeLog,v retrieving revision 1.290 diff -u -U0 -r1.290 ChangeLog --- man/ChangeLog 23 Feb 2005 15:33:32 -0000 1.290 +++ man/ChangeLog 9 Mar 2005 05:16:46 -0000 ＠＠ -0,0 +1,5 ＠＠ +2005-01-19 Aidan Kehoe <kehoea(a)parhasard.net> + + * lispref/mule.texi (CCL Example): Detail an implementation of the + web's URL encoding as a CCL coding system example. + Index: man/lispref/mule.texi =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/man/lispref/mule.texi,v retrieving revision 1.4.2.2 diff -u -r1.4.2.2 mule.texi --- man/lispref/mule.texi 20 Aug 2002 11:35:49 -0000 1.4.2.2 +++ man/lispref/mule.texi 9 Mar 2005 05:42:38 -0000 ＠＠ -1723,7 +1723,7 ＠＠ * CCL Statements:: Semantics of CCL statements. * CCL Expressions:: Operators and expressions in CCL. * Calling CCL:: Running CCL programs. -* CCL Examples:: The encoding functions for Big5 and KOI-8. +* CCL Example:: A trivial program to transform the Web's URL encoding. ＠end menu ＠node CCL Syntax, CCL Statements, , CCL ＠＠ -1942,7 +1942,7 ＠＠ Shift JIS. CCL_DECODE_SJIS is its inverse.) It is somewhat odd to represent the SJIS operations in infix form. -＠node Calling CCL, CCL Examples, CCL Expressions, CCL +＠node Calling CCL, CCL Example, CCL Expressions, CCL ＠comment Node, Next, Previous, Up ＠subsection Calling CCL ＠＠ -2008,11 +2008,277 ＠＠ Resets the CCL interpreter's internal elapsed time registers. ＠end defun -＠node CCL Examples, , Calling CCL, CCL +＠node CCL Example, , Calling CCL, CCL ＠comment Node, Next, Previous, Up -＠subsection CCL Examples +＠subsection CCL Example - This section is not yet written. + In this section, we describe the implementation of a trivial coding +system to transform from the Web's URL encoding to XEmacs' internal +coding. Many people will have been first exposed to URL encoding when +they saw ``%20'' where they expected a space in a file's name on their +local hard disk; this can happen when a browser saves a file from the +web and doesn't encode the name, as passed from the server, properly. + + URL encoding itself is underspecified with regard to encodings beyond +ASCII. The relevant document, RFC 1738, explicitly doesn't give any +information on how to encode non-ASCII characters, and the ``obvious'' +way---use the %xx values for the octets of the eight bit MIME character +set in which the page was served---breaks when a user types a character +outside that character set. Best practice for web development is to +serve all pages as UTF-8 and treat incoming form data as using that +coding system. (Oh, and gamble that your clients won't ever want to +type anything outside Unicode. But that's not so much of a gamble with +today's client operating systems.) We don't treat non-ASCII in this +example, as dealing with ＠samp{(read-multibyte-character ...)} and +errors therewith would make it much harder to understand. + + Since CCL isn't a very rich language, we move much of the logic that +would ordinarily be computed from operations like ＠code{(member ..)}, +＠code{(and ...)} and ＠code{(or ...)} into tables, from which register +values are read and written, and on which ＠code{if} statements are +predicated. Much more of the implementation of this coding system is +occupied with constructing these tables---in normal Emacs Lisp---than it +is with actual CCL code. + + All the ＠code{defvar} statements we deal with in the next few sections +are surrounded by a ＠code{(eval-and-compile ...)}, which means that the +logic which initializes these variables executes at compile time, and if +XEmacs loads the compiled version of the file, these variables are +initialized as constants. + +＠menu +* Four bits to ASCII:: Two tables used for getting hex digits from ASCII. +* URI Encoding constants:: Useful predefined characters. +* Numeric to ASCII-hexadecimal conversion:: Trivial in Lisp, not so in CCL. +* Characters to be preserved:: No transformation needed for these characters. +* The program to decode to internal format:: . +* The program to encode from internal format:: . + +＠end menu + +＠node Four bits to ASCII, URI Encoding constants, , CCL Example +＠subsubsection Four bits to ASCII + + The first ＠code{defvar} is for +＠code{url-coding-high-order-nybble-as-ascii}, a 256-entry table that +maps from an octet's value to the ASCII encoding for the hex value of +its most significant four bits. That might sound complex, but it isn't; +for decimal 65, hex value ＠samp{#x41}, the entry in the table is the +ASCII encoding of `4'. For decimal 122, ASCII `z', hex value +＠code{#x7a}, ＠code{(elt url-coding-high-order-nybble-as-ascii #x7a)} +after this file is loaded gives the ASCII encoding of 7. + +＠example +(defvar url-coding-high-order-nybble-as-ascii + (let ((val (make-vector 256 0)) + (i 0)) + (while (< i (length val)) + (aset val i (char-int (aref (format "%02X" i) 0))) + (setq i (1+ i))) + val) + "Table to find an ASCII version of an octet's most significant 4 bits.") +＠end example + + The next table, ＠code{url-coding-low-order-nybble-as-ascii} is almost +the same thing, but this time it has a map for the hex encoding of the +low-order four bits. So the sixty-fifth entry (offset ＠samp{#x51}) is +the ASCII encoding of `1', the hundred-and-twenty-second (offset +＠samp{#x7a}) is the ASCII encoding of `A'. + +＠example +(defvar url-coding-low-order-nybble-as-ascii + (let ((val (make-vector 256 0)) + (i 0)) + (while (< i (length val)) + (aset val i (char-int (aref (format "%02X" i) 1))) + (setq i (1+ i))) + val) + "Table to find an ASCII version of an octet's least significant 4 bits.") +＠end example + +＠node URI Encoding constants, Numeric to ASCII-hexadecimal conversion, Four bits to ASCII, CCL Example +＠subsubsection URI Encoding constants + + Next, we have a couple of variables that make the CCL code more +readable. The first is the ASCII encoding of the percentage sign; this +character is used as an escape code, to start the encoding of a +non-printable character. For historical reasons, URL encoding allows +the space character to be encoded as a plus sign--it does make typing +URLs like ＠samp{http://google.com/search?q=XEmacs+home+page} easier--and +as such, we have to check when decoding for this value, and map it to +the space character. When doing this in CCL, we use the +＠code{url-coding-escaped-space-code} variable. + +＠example +(defvar url-coding-escape-character-code (char-int ?%) + "The code point for the percentage sign, in ASCII.") + +(defvar url-coding-escaped-space-code (char-int ?+) + "The URL-encoded value of the space character, that is, +.") +＠end example + +＠node Numeric to ASCII-hexadecimal conversion +＠subsubsection Numeric to ASCII-hexadecimal conversion + + Now, we have a couple of utility tables that wouldn't be necessary in +a more expressive programming language than is CCL. The first is sixteen +in length, and maps a hexadecimal number to the ASCII encoding of that +number; so zero maps to ASCII `0', ten maps to ASCII `A.' The second +does the reverse; that is, it maps an ASCII character to its value when +interpreted as a hexadecimal digit. ('A' => 10, 'c' => 12, '2' => 2, as +a few examples.) + +＠example +(defvar url-coding-hex-digit-table + (let ((i 0) + (val (make-vector 16 0))) + (while (< i 16) + (aset val i (char-int (aref (format "%X" i) 0))) + (setq i (1+ i))) + val) + "A map from a hexadecimal digit's numeric value to its encoding in ASCII.") + +(defvar url-coding-latin-1-as-hex-table + (let ((val (make-vector 256 0)) + (i 0)) + (while (< i (length val)) + ;; Get a hex val for this ASCII character. + (aset val i (string-to-int (format "%c" i) 16)) + (setq i (1+ i))) + val) + "A map from Latin 1 code points to their values as hexadecimal digits.") +＠end example + +＠node Characters to be preserved +＠subsubsection Characters to be preserved + + And finally, the last of these tables. URL encoding says that +alphanumeric characters, the underscore, hyphen and the full stop +＠footnote{That's what the standards call it, though my North American +readers will be more familiar with it as the period character.} retain +their ASCII encoding, and don't undergo transformation. +＠code{url-coding-should-preserve-table} is an array in which the entries +are one if the corresponding ASCII character should be left as-is, and +zero if they should be transformed. So the entries for all the control +and most of the punctuation charcters are zero. Lisp programmers will +observe that this initialization is particularly inefficient, but +they'll also be aware that this is a long way from an inner loop where +every nanosecond counts. + +＠example +(defvar url-coding-should-preserve-table + (let ((preserve + (list ?- ?_ ?. ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o + ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D ?E ?F ?G + ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y + ?Z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) + (i 0) + (res (make-vector 256 0))) + (while (< i 256) + (when (member (int-char i) preserve) + (aset res i 1)) + (setq i (1+ i))) + res) + "A 256-entry array of flags, indicating whether or not to preserve an +octet as its ASCII encoding.") +＠end example + +＠node The program to decode to internal format +＠subsubsection The program to decode to internal format + + After the almost interminable tables, we get to the CCL. The first +CCL program, ＠code{ccl-decode-urlcoding} decodes from the URL coding to +our internal format; since this version of CCL doesn't have support for +error checking on the input, we don't do any verification on it. + +The buffer magnification--approximate ratio of the size of the output +buffer to the size of the input buffer--is declared as one, because +fractional values aren't allowed. (Since all those %20's will map to +` ', the length of the output text will be less than that of the input +text.) + +So, first we read an octet from the input buffer into register +＠samp{r0}, to set up the loop. Next, we start the loop, with a +＠code{(loop ...)} statement, and we check if the value in ＠samp{r0} is a +percentage sign. (Note the comma before +＠code{url-coding-escape-character-code}; since CCL is a Lisp macro +language, we can break out of the macro evaluation with a comman, and as +such, ``＠code{,url-coding-escape-character-code}'' will be evaluated as a +literal `37.') + +If it is a percentage sign, we read the next two octets into ＠samp{r2} +and ＠samp{r3}, and convert them into their hexadecimal numeric values, +using the ＠code{url-coding-latin-1-as-hex-table} array declared above. +(But again, it'll be interpreted as a literal array.) We then left +shift the first by four bits, mask the two together, and write the +result to the output buffer. + +If it isn't a percentage sign, and it is a `+' sign, we write a +space--hexadecimal 20--to the output buffer. + +If none of those things are true, we pass the octet to the output buffer +untransformed. (This could be a place to put error checking, in a more +expressive language.) We then read one more octet from the input +buffer, and move to the next iteration of the loop. + +＠example +(define-ccl-program ccl-decode-urlcoding + `(1 + ((read r0) + (loop + (if (r0 == ,url-coding-escape-character-code) + ((read r2 r3) + ;; Assign the value at offset r2 in the url-coding-hex-digit-table + ;; to r3. + (r2 = r2 ,url-coding-latin-1-as-hex-table) + (r3 = r3 ,url-coding-latin-1-as-hex-table) + (r2 <<= 4) + (r3 |= r2) + (write r3)) + (if (r0 == ,url-coding-escaped-space-code) + (write #x20) + (write r0))) + (read r0) + (repeat)))) + "CCL program to take URI-encoded ASCII text and transform it to our +internal encoding. ") +＠end example + +＠node The program to encode from internal format +＠subsubsection The program to encode from internal format + + Next, we see the CCL program to encode ASCII text as URL coded text. +Here, the buffer magnification is specified as three, to account for ` ' +mapping to %20, etc. As before, we read an octet from the input into +＠samp{r0}, and move into the body of the loop. Next, we check if we +should preserve the value of this octet, by reading from offset +＠samp{r0} in the ＠code{url-coding-should-preserve-table} into ＠samp{r1}. +Then we have an ＠samp{if} statement predicated on the value in +＠samp{r1}; for the true branch, we write the input octet directly. For +the false branch, we write a percentage sign, the ASCII encoding of the +high four bits in hex, and then the ASCII encoding of the low four bits +in hex. + +We then read an octet from the input into ＠samp{r0}, and repeat the loop. + +＠example +(define-ccl-program ccl-encode-urlcoding + `(3 + ((read r0) + (loop + (r1 = r0 ,url-coding-should-preserve-table) + ;; If we should preserve the value, just write the octet directly. + (if r1 + (write r0) + ;; else, write a percentage sign, and the hex value of the octet, in + ;; an ASCII-friendly format. + ((write ,url-coding-escape-character-code) + (write r0 ,url-coding-high-order-nybble-as-ascii) + (write r0 ,url-coding-low-order-nybble-as-ascii))) + (read r0) + (repeat)))) + "CCL program to encode octets (almost) according to RFC 1738") +＠end example ＠node Category Tables, , CCL, MULE ＠section Category Tables -- Institute of Policy and Planning Sciences http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software.

4 participants
3 comments

[PATCH] Sync of occur-mode with GNU Emacs CVS. 18 years, 4 months

Malcolm Purvis

This is a sync of occur-mode with GNU Emacs 22.0.50.1 (CVS). Note that these are 21.5 core lisp files. New features include syntax hightlighting of the matched regular expression, the ability to rename the occur buffer, the ability to search multiple buffers and minor mode that allows movement between the matching lines while remaining in the occur buffer. Since the occur code has started using font-lock features it has been moved out of replace.el into its own files because the necessary functions are not available to replace.el during the dumping stage. This patch also changes the behaviour of read-buffer slightly to conform with GNU Emacs usage: It can return an empty string if 'require-match' is t and 'default' is nil. Previously it would insist that a buffer be entered. A search through the package code has shown that this is the only place that relies of this combination of argument values. Malcolm lisp/ChangeLog addition: 2005-10-10 Malcolm Purvis <malcolmp(a)xemacs.org> * minibuf.el: * minibuf.el (read-buffer): Follow GNU Emacs behaviour: Can return empty string if require-match is t and default is nil. * replace.el: Moved occur code to occur.el * simple.el: * simple.el (line-number-at-pos): New. * subr.el: * subr.el (delete-dups): New. * occur.el: New. Sync with 22.0.50.1 (CVS) * next-error.el: New. Sync with 22.0.50.1 (CVS) xemacs-occur source patch: Diff command: cvs -q diff -u Files affected: lisp/subr.el lisp/simple.el lisp/replace.el lisp/minibuf.el Index: lisp/minibuf.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/minibuf.el,v retrieving revision 1.29 diff -u -r1.29 minibuf.el --- lisp/minibuf.el 2005/04/14 05:58:46 1.29 +++ lisp/minibuf.el 2005/10/09 20:52:48 ＠＠ -23,8 +23,8 ＠＠ ;; 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, 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: all the minibuffer history stuff is synched with ;;; 19.30. Not sure about the rest. ＠＠ -1495,7 +1495,7 ＠＠ (setq result default) nil) ((not default) - t) + nil) ((not (get-buffer default)) t) (t Index: lisp/replace.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/replace.el,v retrieving revision 1.11 diff -u -r1.11 replace.el --- lisp/replace.el 2005/02/23 22:09:15 1.11 +++ lisp/replace.el 2005/10/09 20:52:50 ＠＠ -19,8 +19,8 ＠＠ ;; 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. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34 [Partially]. ＠＠ -455,271 +455,7 ＠＠ (message "%d occurrences" count))))) -(defvar occur-mode-map ()) -(if occur-mode-map - () - (setq occur-mode-map (make-sparse-keymap)) - (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs - (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs - (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) - (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence)) - -(defvar occur-buffer nil) -(defvar occur-nlines nil) -(defvar occur-pos-list nil) - -(defun occur-mode () - "Major mode for output from \\[occur]. -\\<occur-mode-map>Move point to one of the items in this buffer, then use -\\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. -Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. - -\\{occur-mode-map}" - (kill-all-local-variables) - (use-local-map occur-mode-map) - (setq major-mode 'occur-mode) - (setq mode-name (gettext "Occur")) ; XEmacs - (make-local-variable 'occur-buffer) - (make-local-variable 'occur-nlines) - (make-local-variable 'occur-pos-list) - (require 'mode-motion) ; XEmacs - (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs - (run-hooks 'occur-mode-hook)) - -;; FSF Version of next function: -; (let (buffer pos) -; (save-excursion -; (set-buffer (window-buffer (posn-window (event-end event)))) -; (save-excursion -; (goto-char (posn-point (event-end event))) -; (setq pos (occur-mode-find-occurrence)) -; (setq buffer occur-buffer))) -; (pop-to-buffer buffer) -; (goto-char (marker-position pos)))) - -(defun occur-mode-mouse-goto (event) - "Go to the occurrence highlighted by mouse. -This function should be bound to a mouse key in the `*Occur*' buffer." - (interactive "e") - (let ((window-save (selected-window)) - (frame-save (selected-frame))) - ;; preserve the window/frame setup - (unwind-protect - (progn - (mouse-set-point event) - (occur-mode-goto-occurrence)) - (select-frame frame-save) - (select-window window-save)))) - -;; Called occur-mode-find-occurrence in FSF -(defun occur-mode-goto-occurrence () - "Go to the occurrence the current line describes." - (interactive) - (if (or (null occur-buffer) - (null (buffer-name occur-buffer))) - (progn - (setq occur-buffer nil - occur-pos-list nil) - (error "Buffer in which occurrences were found is deleted"))) - (let* ((line-count - (count-lines (point-min) - (save-excursion - (beginning-of-line) - (point)))) - (occur-number (save-excursion - (beginning-of-line) - (/ (1- line-count) - (cond ((< occur-nlines 0) - (- 2 occur-nlines)) - ((> occur-nlines 0) - (+ 2 (* 2 occur-nlines))) - (t 1))))) - (pos (nth occur-number occur-pos-list)) - ;; removed t arg from Bob Weiner, 10/6/95 - (window (get-buffer-window occur-buffer)) - (occur-source-buffer occur-buffer)) - (if (< line-count 1) - (error "No occurrence on this line")) - (or pos - (error "No occurrence on this line")) - ;; XEmacs: don't raise window unless it isn't visible - ;; allow for the possibility that the occur buffer is on another frame - (or (and window - (window-live-p window) - (frame-visible-p (window-frame window)) - (set-buffer occur-source-buffer)) - (and (pop-to-buffer occur-source-buffer) - (setq window (get-buffer-window occur-source-buffer)))) - (goto-char pos) - (set-window-point window pos))) - - -(defvar list-matching-lines-default-context-lines 0 - "*Default number of context lines to include around a `list-matching-lines' -match. A negative number means to include that many lines before the match. -A positive number means to include that many lines both before and after.") - -;; XEmacs addition -;;; Damn you Jamie, this is utter trash. -(defvar list-matching-lines-whole-buffer t - "If t, occur operates on whole buffer, otherwise occur starts from point. -default is t.") - -(define-function 'occur 'list-matching-lines) -(defun list-matching-lines (regexp &optional nlines) - "Show all lines in the current buffer containing a match for REGEXP. - -If a match spreads across multiple lines, all those lines are shown. - -If variable `list-matching-lines-whole-buffer' is non-nil, the entire -buffer is searched, otherwise search begins at point. - -Each line is displayed with NLINES lines before and after, or -NLINES -before if NLINES is negative. -NLINES defaults to `list-matching-lines-default-context-lines'. -Interactively it is the prefix arg. - -The lines are shown in a buffer named `*Occur*'. -It serves as a menu to find any of the occurrences in this buffer. -\\[describe-mode] in that buffer will explain how." - (interactive - ;; XEmacs change - (list (let* ((default (or (symbol-near-point) - (and regexp-history - (car regexp-history)))) - (minibuffer-history-minimum-string-length 0) - (input - (if default - ;; rewritten for I18N3 snarfing - (read-from-minibuffer - (format "List lines matching regexp (default `%s'): " - default) nil nil nil 'regexp-history nil - default) - (read-from-minibuffer - "List lines matching regexp: " - nil nil nil - 'regexp-history)))) - (if (and (equal input "") default) - (progn - (setq input default) - (setcar regexp-history default))) - ;; clear extra entries - (setcdr regexp-history (delete (car regexp-history) - (cdr regexp-history))) - input) - current-prefix-arg)) - (if (equal regexp "") - (error "Must pass non-empty regexp to `list-matching-lines'")) - (setq nlines (if nlines (prefix-numeric-value nlines) - list-matching-lines-default-context-lines)) - (let ((first t) - (dir default-directory) - (buffer (current-buffer)) - (linenum 1) - (prevpos (point-min)) - ;; The rest of this function is very different from FSF. - ;; Presumably that's due to Jamie's misfeature - (final-context-start (make-marker))) - (if (not list-matching-lines-whole-buffer) - (save-excursion - (beginning-of-line) - (setq linenum (1+ (count-lines (point-min) (point)))) - (setq prevpos (point)))) - (with-output-to-temp-buffer "*Occur*" - (save-excursion - (set-buffer standard-output) - (setq default-directory dir) - ;; We will insert the number of lines, and "lines", later. - ;; #### Needs fixing for I18N3 - (let ((print-escape-newlines t)) - (insert (format " matching %s in buffer %s.\n" - regexp (buffer-name buffer)))) - (occur-mode) - (setq occur-buffer buffer) - (setq occur-nlines nlines) - (setq occur-pos-list ())) - (if (eq buffer standard-output) - (goto-char (point-max))) - (with-interactive-search-caps-disable-folding regexp t - (save-excursion - (if list-matching-lines-whole-buffer - (beginning-of-buffer)) - (message "Searching for %s ..." regexp) - ;; Find next match, but give up if prev match was at end of buffer. - (while (and (not (= prevpos (point-max))) - (re-search-forward regexp nil t)) - (goto-char (match-beginning 0)) - (beginning-of-line) - (save-match-data - (setq linenum (+ linenum (count-lines prevpos (point))))) - (setq prevpos (point)) - (goto-char (match-end 0)) - (let* ((start (save-excursion - (goto-char (match-beginning 0)) - (forward-line (if (< nlines 0) nlines (- nlines))) - (point))) - (end (save-excursion - (goto-char (match-end 0)) - (if (> nlines 0) - (forward-line (1+ nlines)) - (forward-line 1)) - (point))) - (tag (format "%5d" linenum)) - (empty (make-string (length tag) ?\ )) - tem) - (save-excursion - (setq tem (make-marker)) - (set-marker tem (point)) - (set-buffer standard-output) - (setq occur-pos-list (cons tem occur-pos-list)) - (or first (zerop nlines) - (insert "--------\n")) - (setq first nil) - (insert-buffer-substring buffer start end) - (set-marker final-context-start - (- (point) (- end (match-end 0)))) - (backward-char (- end start)) - (setq tem (if (< nlines 0) (- nlines) nlines)) - (while (> tem 0) - (insert empty ?:) - (forward-line 1) - (setq tem (1- tem))) - (let ((this-linenum linenum)) - (while (< (point) final-context-start) - (if (null tag) - (setq tag (format "%5d" this-linenum))) - (insert tag ?:) - ;; FSFmacs -- - ;; we handle this using mode-motion-highlight-line, above. - ;; (put-text-property (save-excursion - ;; (beginning-of-line) - ;; (point)) - ;; (save-excursion - ;; (end-of-line) - ;; (point)) - ;; 'mouse-face 'highlight) - (forward-line 1) - (setq tag nil) - (setq this-linenum (1+ this-linenum))) - (while (<= (point) final-context-start) - (insert empty ?:) - (forward-line 1) - (setq this-linenum (1+ this-linenum)))) - (while (< tem nlines) - (insert empty ?:) - (forward-line 1) - (setq tem (1+ tem))) - (goto-char (point-max))) - (forward-line 1))) - (set-buffer standard-output) - ;; Put positions in increasing order to go with buffer. - (setq occur-pos-list (nreverse occur-pos-list)) - (goto-char (point-min)) - (if (= (length occur-pos-list) 1) - (insert "1 line") - (insert (format "%d lines" (length occur-pos-list)))) - (if (interactive-p) - (message "%d matching lines." (length occur-pos-list)))))))) +;;; occur code moved to occur.el ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. Index: lisp/simple.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/simple.el,v retrieving revision 1.52 diff -u -r1.52 simple.el --- lisp/simple.el 2005/10/05 04:32:45 1.52 +++ lisp/simple.el 2005/10/09 20:53:02 ＠＠ -21,12 +21,12 ＠＠ ;; 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. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34 [But not very closely]. -;;; Occasional synching to FSF 21.2, as marked. Comment stuff also -;;; synched, and in newcomment.el. +;;; Occasional synching to FSF 21.2 and FSF 22.0, as marked. Comment stuff +;;; also synched, and in newcomment.el. ;;; Commentary: ＠＠ -745,6 +745,10 ＠＠ (goto-char pos) (line-number nil respect-narrowing)) (1+ (count-lines (if respect-narrowing (point-min) 1) (point-at-bol))))) + +;; FSF 22.0.50.1 (CVS) version of above. +(defun line-number-at-pos (&optional pos) + (line-number pos t)) (defun count-lines (start end &optional ignore-invisible-lines-flag) "Return number of lines between START and END. Index: lisp/subr.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/subr.el,v retrieving revision 1.36 diff -u -r1.36 subr.el --- lisp/subr.el 2005/01/28 02:05:05 1.36 +++ lisp/subr.el 2005/10/09 20:53:06 ＠＠ -23,8 +23,8 ＠＠ ;; 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. +;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 19.34. Some things synched up with later versions. ＠＠ -1619,6 +1619,20 ＠＠ (make-compatible 'eval-next-after-load "") ;; END SYNC WITH FSF 21.2 + +;; BEGIN SYNC WITH FSF 22.0.50.1 (CVS) +(defun delete-dups (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept." + (let ((tail list)) + (while tail + (setcdr tail (delete (car tail) (cdr tail))) + (setq tail (cdr tail)))) + list) + +;; END SYNC WITH FSF 22.0.50.1 (CVS) ;; (defun shell-quote-argument (argument) in process.el. --------------------------------------------------------------------------- ;;; occur.el --- Show all lines in the current buffer containing a match for REGEXP. ;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1996, 1997, 2000, 2001, ;; 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: XEmacs Development Team ;; Keywords: internal ;; 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., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 22.0.50.1 (CVS) (require 'next-error) (defun query-replace-descr (string) (mapconcat 'isearch-text-char-description string "")) (defvar occur-mode-map () "Keymap for `occur-mode'.") (if occur-mode-map () (setq occur-mode-map (make-sparse-keymap)) (set-keymap-name occur-mode-map 'occur-mode-map) ; XEmacs (define-key occur-mode-map 'button2 'occur-mode-mouse-goto) ; XEmacs (define-key occur-mode-map "\C-c\C-c" 'occur-mode-goto-occurrence) (define-key occur-mode-map "\C-m" 'occur-mode-goto-occurrence) (define-key occur-mode-map "o" 'occur-mode-goto-occurrence-other-window) (define-key occur-mode-map "\C-o" 'occur-mode-display-occurrence) (define-key occur-mode-map "\M-n" 'occur-next) (define-key occur-mode-map "\M-p" 'occur-prev) (define-key occur-mode-map "r" 'occur-rename-buffer) (define-key occur-mode-map "c" 'clone-buffer) (define-key occur-mode-map "g" 'revert-buffer) (define-key occur-mode-map "q" 'quit-window) (define-key occur-mode-map "z" 'kill-this-buffer) (define-key occur-mode-map "\C-c\C-f" 'next-error-follow-minor-mode)) (defvar occur-revert-arguments nil "Arguments to pass to `occur-1' to revert an Occur mode buffer. See `occur-revert-function'.") (defcustom occur-mode-hook nil ; XEmacs "Hook run when entering Occur mode." :type 'hook :group 'matching) (defcustom occur-hook nil "Hook run by Occur when there are any matches." :type 'hook :group 'matching) (put 'occur-mode 'mode-class 'special) ;;;###autoload (defun occur-mode () "Major mode for output from \\[occur]. \\<occur-mode-map>Move point to one of the items in this buffer, then use \\[occur-mode-goto-occurrence] to go to the occurrence that the item refers to. Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it. \\{occur-mode-map}" (interactive) (kill-all-local-variables) (use-local-map occur-mode-map) (setq major-mode 'occur-mode) (setq mode-name (gettext "Occur")) ; XEmacs (set (make-local-variable 'revert-buffer-function) 'occur-revert-function) (make-local-variable 'occur-revert-arguments) (add-hook 'change-major-mode-hook 'turn-off-font-lock t t) (setq next-error-function 'occur-next-error) (require 'mode-motion) ; XEmacs (setq mode-motion-hook 'mode-motion-highlight-line) ; XEmacs (run-mode-hooks 'occur-mode-hook)) (defun occur-revert-function (ignore1 ignore2) "Handle `revert-buffer' for Occur mode buffers." (apply 'occur-1 (append occur-revert-arguments (list (buffer-name))))) ;; FSF Version of next function: ; (defun occur-mode-mouse-goto (event) ; "In Occur mode, go to the occurrence whose line you click on." ; (interactive "e") ; (let (pos) ; (save-excursion ; (set-buffer (window-buffer (posn-window (event-end event)))) ; (save-excursion ; (goto-char (posn-point (event-end event))) ; (setq pos (occur-mode-find-occurrence)))) ; (pop-to-buffer (marker-buffer pos)) ; (goto-char pos))) (defun occur-mode-mouse-goto (event) "Go to the occurrence highlighted by mouse. This function should be bound to a mouse key in the `*Occur*' buffer." (interactive "e") (let ((window-save (selected-window)) (frame-save (selected-frame))) ;; preserve the window/frame setup (unwind-protect (progn (mouse-set-point event) (occur-mode-goto-occurrence)) (select-frame frame-save) (select-window window-save)))) (defun occur-mode-find-occurrence () (let ((pos (get-text-property (point) 'occur-target))) (unless pos (error "No occurrence on this line")) (unless (buffer-live-p (marker-buffer pos)) (error "Buffer for this occurrence was killed")) pos)) (defun occur-mode-goto-occurrence () "Go to the occurrence the current line describes." (interactive) (let ((pos (occur-mode-find-occurrence))) (pop-to-buffer (marker-buffer pos)) (goto-char pos))) (defun occur-mode-goto-occurrence-other-window () "Go to the occurrence the current line describes, in another window." (interactive) (let ((pos (occur-mode-find-occurrence))) (switch-to-buffer-other-window (marker-buffer pos)) (goto-char pos))) (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) (let ((pos (occur-mode-find-occurrence)) window ;; Bind these to ensure `display-buffer' puts it in another window. same-window-buffer-names same-window-regexps) (setq window (display-buffer (marker-buffer pos))) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos)))) (defun occur-find-match (n search message) (if (not n) (setq n 1)) (let ((r)) (while (> n 0) (setq r (funcall search (point) 'occur-match)) (and r (get-text-property r 'occur-match) (setq r (funcall search r 'occur-match))) (if r (goto-char r) (error message)) (setq n (1- n))))) (defun occur-next (&optional n) "Move to the Nth (default 1) next match in an Occur mode buffer." (interactive "p") (occur-find-match n #'next-single-property-change "No more matches")) (defun occur-prev (&optional n) "Move to the Nth (default 1) previous match in an Occur mode buffer." (interactive "p") (occur-find-match n #'previous-single-property-change "No earlier matches")) (defun occur-next-error (&optional argp reset) "Move to the Nth (default 1) next match in an Occur mode buffer. Compatibility function for \\[next-error] invocations." (interactive "p") ;; we need to run occur-find-match from within the Occur buffer (with-current-buffer ;; Choose the buffer and make it current. (if (next-error-buffer-p (current-buffer)) (current-buffer) (next-error-find-buffer nil nil (lambda () (eq major-mode 'occur-mode)))) (goto-char (cond (reset (point-min)) ((< argp 0) (line-beginning-position)) ((line-end-position)))) (occur-find-match (abs argp) (if (> 0 argp) #'previous-single-property-change #'next-single-property-change) "No more matches") ;; In case the *Occur* buffer is visible in a nonselected window. (set-window-point (get-buffer-window (current-buffer)) (point)) (occur-mode-goto-occurrence))) (defface match '((((class color) (background light)) (:background "Tan")) (((class color) (background dark)) (:background "RoyalBlue3")) (((class color)) (:background "blue" :foreground "white")) (((type tty) (class mono)) (:inverse-video t)) (t (:background "gray"))) "Face used to highlight matches permanently." :group 'matching :version "22.1") (defcustom list-matching-lines-default-context-lines 0 "*Default number of context lines included around `list-matching-lines' matches. A negative number means to include that many lines before the match. A positive number means to include that many lines both before and after." :type 'integer :group 'matching) (defalias 'list-matching-lines 'occur) (defcustom list-matching-lines-face 'match "*Face used by \\[list-matching-lines] to show the text that matches. If the value is nil, don't highlight the matching portions specially." :type 'face :group 'matching) (defcustom list-matching-lines-buffer-name-face 'underline "*Face used by \\[list-matching-lines] to show the names of buffers. If the value is nil, don't highlight the buffer names specially." :type 'face :group 'matching) (defun occur-accumulate-lines (count &optional keep-props) (save-excursion (let ((forwardp (> count 0)) result beg end) (while (not (or (zerop count) (if forwardp (eobp) (bobp)))) (setq count (+ count (if forwardp -1 1))) (setq beg (line-beginning-position) end (line-end-position)) (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) (text-property-not-all beg end 'fontified t)) (if (fboundp 'jit-lock-fontify-now) (jit-lock-fontify-now beg end))) (push (funcall (if keep-props #'buffer-substring #'buffer-substring-no-properties) beg end) result) (forward-line (if forwardp 1 -1))) (nreverse result)))) (defun occur-read-primary-args () (list (let* ((default (or (symbol-near-point) (and regexp-history (car regexp-history)))) (minibuffer-history-minimum-string-length 0) (input (if default ;; XEmacs: rewritten for I18N3 snarfing (read-from-minibuffer (format "List lines matching regexp (default `%s'): " default) nil nil nil 'regexp-history nil default) (read-from-minibuffer "List lines matching regexp: " nil nil nil 'regexp-history)))) (if (equal input "") default input)) (when current-prefix-arg (prefix-numeric-value current-prefix-arg)))) ;;;###autoload (defun occur-rename-buffer (&optional unique-p interactive-p) "Rename the current *Occur* buffer to *Occur: original-buffer-name*. Here `original-buffer-name' is the buffer name were Occur was originally run. When given the prefix argument, or called non-interactively, the renaming will not clobber the existing buffer(s) of that name, but use `generate-new-buffer-name' instead. You can add this to `occur-hook' if you always want a separate *Occur* buffer for each buffer where you invoke `occur'." (interactive "P\np") (with-current-buffer (if (eq major-mode 'occur-mode) (current-buffer) (get-buffer "*Occur*")) (rename-buffer (concat "*Occur: " (mapconcat #'buffer-name (car (cddr occur-revert-arguments)) "/") "*") (or unique-p (not interactive-p))))) ;;;###autoload (defun occur (regexp &optional nlines) "Show all lines in the current buffer containing a match for REGEXP. This function can not handle matches that span more than one line. Each line is displayed with NLINES lines before and after, or -NLINES before if NLINES is negative. NLINES defaults to `list-matching-lines-default-context-lines'. Interactively it is the prefix arg. The lines are shown in a buffer named `*Occur*'. It serves as a menu to find any of the occurrences in this buffer. \\<occur-mode-map>\\[describe-mode] in that buffer will explain how. If REGEXP contains upper case characters (excluding those preceded by `\\'), the matching is case-sensitive." (interactive (occur-read-primary-args)) (occur-1 regexp nlines (list (current-buffer)))) ;;;###autoload (defun multi-occur (bufs regexp &optional nlines) "Show all lines in buffers BUFS containing a match for REGEXP. This function acts on multiple buffers; otherwise, it is exactly like `occur'." (interactive (cons (let* ((bufs (list (read-buffer "First buffer to search: " (current-buffer) t))) (buf nil) (ido-ignore-item-temp-list bufs)) (while (not (string-equal (setq buf (read-buffer (if (and-boundp 'read-buffer-function '(eq read-buffer-function 'ido-read-buffer)) "Next buffer to search (C-j to end): " "Next buffer to search (RET to end): ") nil t)) "")) (add-to-list 'bufs buf) (setq ido-ignore-item-temp-list bufs)) (nreverse (mapcar #'get-buffer bufs))) (occur-read-primary-args))) (occur-1 regexp nlines bufs)) ;;;###autoload (defun multi-occur-by-filename-regexp (bufregexp regexp &optional nlines) "Show all lines matching REGEXP in buffers named by BUFREGEXP. See also `multi-occur'." (interactive (cons (let* ((default (car regexp-history)) (input (read-from-minibuffer "List lines in buffers whose filename matches regexp: " nil nil nil 'regexp-history))) (if (equal input "") default input)) (occur-read-primary-args))) (when bufregexp (occur-1 regexp nlines (delq nil (mapcar (lambda (buf) (when (and (buffer-file-name buf) (string-match bufregexp (buffer-file-name buf))) buf)) (buffer-list)))))) (defun occur-1 (regexp nlines bufs &optional buf-name) (unless buf-name (setq buf-name "*Occur*")) (let (occur-buf (active-bufs (delq nil (mapcar #'(lambda (buf) (when (buffer-live-p buf) buf)) bufs)))) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. (when (member buf-name (mapcar 'buffer-name active-bufs)) (with-current-buffer (get-buffer buf-name) (rename-uniquely))) ;; Now find or create the output buffer. ;; If we just renamed that buffer, we will make a new one here. (setq occur-buf (get-buffer-create buf-name)) (with-current-buffer occur-buf (occur-mode) (let ((inhibit-read-only t)) (erase-buffer) (let ((count (occur-engine regexp active-bufs occur-buf (or nlines list-matching-lines-default-context-lines) (and case-fold-search (no-upper-case-p regexp t)) list-matching-lines-buffer-name-face nil list-matching-lines-face t))) (let* ((bufcount (length active-bufs)) (diff (- (length bufs) bufcount))) (message "Searched %d buffer%s%s; %s match%s for `%s'" bufcount (if (= bufcount 1) "" "s") (if (zerop diff) "" (format " (%d killed)" diff)) (if (zerop count) "no" (format "%d" count)) (if (= count 1) "" "es") regexp)) (setq occur-revert-arguments (list regexp nlines bufs)) (if (= count 0) (kill-buffer occur-buf) (display-buffer occur-buf) (setq next-error-last-buffer occur-buf) (setq buffer-read-only t) (set-buffer-modified-p nil) (run-hooks 'occur-hook))))))) (defun occur-engine-add-prefix (lines) (mapcar #'(lambda (line) (concat " :" line "\n")) lines)) (defun occur-engine (regexp buffers out-buf nlines case-fold-search title-face prefix-face match-face keep-props) (with-current-buffer out-buf (let ((globalcount 0) ;; Don't generate undo entries for creation of the initial contents. (buffer-undo-list t) (coding nil)) ;; Map over all the buffers (dolist (buf buffers) (when (buffer-live-p buf) (let ((matches 0) ;; count of matched lines (lines 1) ;; line count (matchbeg 0) (origpt nil) (begpt nil) (endpt nil) (marker nil) (curstring "") (headerpt (with-current-buffer out-buf (point)))) (save-excursion (set-buffer buf) (or coding ;; Set CODING only if the current buffer locally ;; binds buffer-file-coding-system. (not (local-variable-p 'buffer-file-coding-system (current-buffer))) (setq coding buffer-file-coding-system)) (save-excursion (goto-char (point-min)) ;; begin searching in the buffer (while (not (eobp)) (setq origpt (point)) (when (setq endpt (re-search-forward regexp nil t)) (setq matches (1+ matches)) ;; increment match count (setq matchbeg (match-beginning 0)) (setq lines (+ lines (1- (count-lines origpt endpt)))) (save-excursion (goto-char matchbeg) (setq begpt (line-beginning-position) endpt (line-end-position))) (setq marker (make-marker)) (set-marker marker matchbeg) (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) (text-property-not-all begpt endpt 'fontified t)) (if (fboundp 'jit-lock-fontify-now) (jit-lock-fontify-now begpt endpt))) (setq curstring (buffer-substring begpt endpt)) ;; Depropertize the string, and maybe ;; highlight the matches (let ((len (length curstring)) (start 0)) (unless keep-props (set-text-properties 0 len nil curstring)) (while (and (< start len) (string-match regexp curstring start)) (add-text-properties (match-beginning 0) (match-end 0) (append `(occur-match t) (when match-face ;; Use `face' rather than `font-lock-face' here ;; so as to override faces copied from the buffer. `(face ,match-face))) curstring) (setq start (match-end 0)))) ;; Generate the string to insert for this match (let* ((out-line (concat ;; Using 7 digits aligns tabs properly. (apply #'propertize (format "%7d:" lines) (append (when prefix-face `(font-lock-face prefix-face)) '(occur-prefix t))) ;; We don't put `mouse-face' on the newline, ;; because that loses. And don't put it ;; on context lines to reduce flicker. (propertize curstring 'mouse-face 'highlight) "\n")) (data (if (= nlines 0) ;; The simple display style out-line ;; The complex multi-line display ;; style. Generate a list of lines, ;; concatenate them all together. (apply #'concat (nconc (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props)))) (list out-line) (if (> nlines 0) (occur-engine-add-prefix (cdr (occur-accumulate-lines (1+ nlines) keep-props))))))))) ;; Actually insert the match display data (with-current-buffer out-buf (let ((beg (point)) (end (progn (insert data) (point)))) (unless (= nlines 0) (insert "-------\n")) (add-text-properties beg end `(occur-target ,marker help-echo "mouse-2: go to this occurrence"))))) (goto-char endpt)) (if endpt (progn (setq lines (1+ lines)) ;; On to the next match... (forward-line 1)) (goto-char (point-max)))))) (when (not (zerop matches)) ;; is the count zero? (setq globalcount (+ globalcount matches)) (with-current-buffer out-buf (goto-char headerpt) (let ((beg (point)) end) (insert (format "%d match%s for \"%s\" in buffer: %s\n" matches (if (= matches 1) "" "es") regexp (buffer-name buf))) (setq end (point)) (add-text-properties beg end (append (when title-face `(font-lock-face ,title-face)) `(occur-title ,buf)))) (goto-char (point-min))))))) (if coding ;; CODING is buffer-file-coding-system of the first buffer ;; that locally binds it. Let's use it also for the output ;; buffer. (set-buffer-file-coding-system coding)) ;; Return the number of matches globalcount))) (provide 'occur) --------------------------------------------------------------------------- ;;; next-error.el --- Next error support framework ;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999, ;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: XEmacs Development Team ;; Keywords: internal ;; 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., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Synched up with: FSF 22.0.50.1 (CVS) (defgroup next-error nil "`next-error' support framework." :group 'compilation :version "22.1") (defface next-error '((t (:inherit region))) "Face used to highlight next error locus." :group 'next-error :version "22.1") (defcustom next-error-highlight 0.1 "*Highlighting of locations in selected source buffers. If number, highlight the locus in `next-error' face for given time in seconds. If t, use persistent overlays fontified in `next-error' face. If nil, don't highlight the locus in the source buffer. If `fringe-arrow', indicate the locus by the fringe arrow." :type '(choice (number :tag "Delay") (const :tag "Persistent overlay" t) (const :tag "No highlighting" nil) (const :tag "Fringe arrow" 'fringe-arrow)) :group 'next-error :version "22.1") (defcustom next-error-highlight-no-select 0.1 "*Highlighting of locations in non-selected source buffers. If number, highlight the locus in `next-error' face for given time in seconds. If t, use persistent overlays fontified in `next-error' face. If nil, don't highlight the locus in the source buffer. If `fringe-arrow', indicate the locus by the fringe arrow." :type '(choice (number :tag "Delay") (const :tag "Persistent overlay" t) (const :tag "No highlighting" nil) (const :tag "Fringe arrow" 'fringe-arrow)) :group 'next-error :version "22.1") (defcustom next-error-hook nil "*List of hook functions run by `next-error' after visiting source file." :type 'hook :group 'next-error) (defvar next-error-highlight-timer nil) ;(defvar next-error-overlay-arrow-position nil) ;(put 'next-error-overlay-arrow-position 'overlay-arrow-string "=>") ;(add-to-list 'overlay-arrow-variable-list 'next-error-overlay-arrow-position) (defvar next-error-last-buffer nil "The most recent `next-error' buffer. A buffer becomes most recent when its compilation, grep, or similar mode is started, or when it is used with \\[next-error] or \\[compile-goto-error].") (defvar next-error-function nil "Function to use to find the next error in the current buffer. The function is called with 2 parameters: ARG is an integer specifying by how many errors to move. RESET is a boolean which, if non-nil, says to go back to the beginning of the errors before moving. Major modes providing compile-like functionality should set this variable to indicate to `next-error' that this is a candidate buffer and how to navigate in it.") (make-variable-buffer-local 'next-error-function) (defsubst next-error-buffer-p (buffer &optional avoid-current extra-test-inclusive extra-test-exclusive) "Test if BUFFER is a `next-error' capable buffer. If AVOID-CURRENT is non-nil, treat the current buffer as an absolute last resort only. The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer that normally would not qualify. If it returns t, the buffer in question is treated as usable. The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer that would normally be considered usable. If it returns nil, that buffer is rejected." (and (buffer-name buffer) ;First make sure it's live. (not (and avoid-current (eq buffer (current-buffer)))) (with-current-buffer buffer (if next-error-function ; This is the normal test. ;; Optionally reject some buffers. (if extra-test-exclusive (funcall extra-test-exclusive) t) ;; Optionally accept some other buffers. (and extra-test-inclusive (funcall extra-test-inclusive)))))) (defun next-error-find-buffer (&optional avoid-current extra-test-inclusive extra-test-exclusive) "Return a `next-error' capable buffer. If AVOID-CURRENT is non-nil, treat the current buffer as an absolute last resort only. The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer that normally would not qualify. If it returns t, the buffer in question is treated as usable. The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer that would normally be considered usable. If it returns nil, that buffer is rejected." (or ;; 1. If one window on the selected frame displays such buffer, return it. (let ((window-buffers (delete-dups (delq nil (mapcar (lambda (w) (if (next-error-buffer-p (window-buffer w) avoid-current extra-test-inclusive extra-test-exclusive) (window-buffer w))) (window-list)))))) (if (eq (length window-buffers) 1) (car window-buffers))) ;; 2. If next-error-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer (next-error-buffer-p next-error-last-buffer avoid-current extra-test-inclusive extra-test-exclusive)) next-error-last-buffer) ;; 3. If the current buffer is acceptable, choose it. (if (next-error-buffer-p (current-buffer) avoid-current extra-test-inclusive extra-test-exclusive) (current-buffer)) ;; 4. Look for any acceptable buffer. (let ((buffers (buffer-list))) (while (and buffers (not (next-error-buffer-p (car buffers) avoid-current extra-test-inclusive extra-test-exclusive))) (setq buffers (cdr buffers))) (car buffers)) ;; 5. Use the current buffer as a last resort if it qualifies, ;; even despite AVOID-CURRENT. (and avoid-current (next-error-buffer-p (current-buffer) nil extra-test-inclusive extra-test-exclusive) (progn (message "This is the only next-error capable buffer") (current-buffer))) ;; 6. Give up. (error "No next-error capable buffer found"))) ;;;###autoload (defun next-error (&optional arg reset) "Visit next `next-error' message and corresponding source code. If all the error messages parsed so far have been processed already, the message buffer is checked for new ones. A prefix ARG specifies how many error messages to move; negative means move back to previous error messages. Just \\[universal-argument] as a prefix means reparse the error message buffer and start at the first error. The RESET argument specifies that we should restart from the beginning. \\[next-error] normally uses the most recently started compilation, grep, or occur buffer. It can also operate on any buffer with output from the \\[compile], \\[grep] commands, or, more generally, on any buffer in Compilation mode or with Compilation Minor mode enabled, or any buffer in which `next-error-function' is bound to an appropriate function. To specify use of a particular buffer for error messages, type \\[next-error] in that buffer when it is the only one displayed in the current frame. Once \\[next-error] has chosen the buffer for error messages, it runs `next-error-hook' with `run-hooks', and stays with that buffer until you use it in some other buffer which uses Compilation mode or Compilation Minor mode. See variables `compilation-parse-errors-function' and \`compilation-error-regexp-alist' for customization ideas." (interactive "P") (if (consp arg) (setq reset t arg nil)) (when (setq next-error-last-buffer (next-error-find-buffer)) ;; we know here that next-error-function is a valid symbol we can funcall (with-current-buffer next-error-last-buffer (funcall next-error-function (prefix-numeric-value arg) reset) (run-hooks 'next-error-hook)))) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) (defun previous-error (&optional n) "Visit previous `next-error' message and corresponding source code. Prefix arg N says how many error messages to move backwards (or forwards, if negative). This operates on the output from the \\[compile] and \\[grep] commands." (interactive "p") (next-error (- (or n 1)))) (defun first-error (&optional n) "Restart at the first error. Visit corresponding source code. With prefix arg N, visit the source code of the Nth error. This operates on the output from the \\[compile] command, for instance." (interactive "p") (next-error n t)) (defun next-error-no-select (&optional n) "Move point to the next error in the `next-error' buffer and highlight match. Prefix arg N says how many error messages to move forwards (or backwards, if negative). Finds and highlights the source line like \\[next-error], but does not select the source buffer." (interactive "p") (let ((next-error-highlight next-error-highlight-no-select)) (next-error n)) (pop-to-buffer next-error-last-buffer)) (defun previous-error-no-select (&optional n) "Move point to the previous error in the `next-error' buffer and highlight match. Prefix arg N says how many error messages to move backwards (or forwards, if negative). Finds and highlights the source line like \\[previous-error], but does not select the source buffer." (interactive "p") (next-error-no-select (- (or n 1)))) ;;; Internal variable for `next-error-follow-mode-post-command-hook'. (defvar next-error-follow-last-line nil) (define-minor-mode next-error-follow-minor-mode "Minor mode for compilation, occur and diff modes. When turned on, cursor motion in the compilation, grep, occur or diff buffer causes automatic display of the corresponding source code location." :group 'next-error :init-value nil :lighter " Fol" (if (not next-error-follow-minor-mode) (remove-hook 'post-command-hook 'next-error-follow-mode-post-command-hook t) (add-hook 'post-command-hook 'next-error-follow-mode-post-command-hook nil t) (make-local-variable 'next-error-follow-last-line))) ;;; Used as a `post-command-hook' by `next-error-follow-mode' ;;; for the *Compilation* *grep* and *Occur* buffers. (defun next-error-follow-mode-post-command-hook () (unless (equal next-error-follow-last-line (line-number-at-pos)) (setq next-error-follow-last-line (line-number-at-pos)) (condition-case nil (let ((compilation-context-lines nil)) (setq compilation-current-error (point)) (next-error-no-select 0)) (error t)))) (provide 'next-error) --------------------------------------------------------------------------- -- Malcolm Purvis <malcolmp(a)xemacs.org>

2 participants
3 comments

[PATCH] Export lrecord_uid_counter to xemacs-import.a for Cygwin build 18 years, 4 months

Rick Rankin

For the last week or so I've been trying to build from CVS on Windows using Cygwin/gcc, and I've been getting errors from the linker. It was complaining about not being able to find symbol 'lrecord_uid_counter' when building some of the modules. Today, I got some time to track it down. All that was necessary was to add the symbol name to src/xemacs.def.in.in. The patch is below. --Rick Index: src/xemacs.def.in.in =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/xemacs.def.in.in,v retrieving revision 1.10 diff -u -r1.10 xemacs.def.in.in --- src/xemacs.def.in.in 2005/10/25 08:32:50 1.10 +++ src/xemacs.def.in.in 2005/11/20 05:28:16 ＠＠ -207,6 +207,7 ＠＠ lrecord_string /* STRINGP */ lrecord_symbol /* SYMBOLP */ lrecord_type_count /* INIT_EXTERNAL_LRECORD_IMPLEMENTATION */ +lrecord_uid_counter need_to_check_c_alloca /* ALLOCA */ print_readably quit_check_signal_happened /* QUITP */

2 participants
1 comments

[AC21.5] Implicit INLINE_HEADERS in modules don't get instantiated 18 years, 4 months

Stephen J. Turnbull

APPROVE COMMIT 21.5 Per recommendation of Ben. This is not meant to block Marcus's "xemacs.def.in in modules" patch, but it does work for Mac OS X. This seems to have snuck in with the Xft merge commit. Sorry! 2005-11-07 Stephen J. Turnbull <stephen(a)xemacs.org> * inline.c: Include modules headers regardless of HAVE_SHLIB. Reproducing the patch (which was originally sent to xemacs-beta for discussion). In the lrecord code, if error checking is turned on, each Lisp object type automatically gets a error_check_TYPE_name function defined using DECLARE_INLINE_HEADER. For reasons I don't understand well at all, at least on Mac OS X 10.3.9 with GCC 3.3 these functions don't get instantiated for the PostgreSQL and LDAP modules. The patch below wins for me, but it's not very pleasant as it seems to imply it's not possible to get an error-checking build outside of the XEmacs tree. Comments appreciated. diff -rN -u old-xft-integration-new/src/inline.c new-xft-integration-new/src/inline.c --- old-xft-integration-new/src/inline.c 2005-11-05 00:45:16.000000000 +0900 +++ new-xft-integration-new/src/inline.c 2005-11-05 00:45:24.000000000 +0900 ＠＠ -67,11 +67,13 ＠＠ #include "syntax.h" #include "window.h" -#if defined (HAVE_LDAP) && !defined (HAVE_SHLIB) +/* if we demand !define (HAVE_SHLIB) the inlines don't get instantiated */ +#if defined (HAVE_LDAP) #include "../modules/ldap/eldap.h" #endif -#if defined (HAVE_POSTGRESQL) && !defined (HAVE_SHLIB) +/* if we demand !define (HAVE_SHLIB) the inlines don't get instantiated */ +#if defined (HAVE_POSTGRESQL) #include "../modules/postgresql/postgresql.h" #endif -- School of Systems and Information Engineering http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software. -- School of Systems and Information Engineering http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software.

1 participants
0 comments

[21.5] move comment 18 years, 4 months

Stephen J. Turnbull

21.5 "Obviously correct." Will commit in a few days if nobody who knows better tells me it's wrong. :-) 2005-11-26 Stephen J. Turnbull <stephen(a)xemacs.org> * dumper.c: Move comment to where it apparently belongs. Index: src/dumper.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/dumper.c,v retrieving revision 1.32 diff -u -r1.32 dumper.c --- src/dumper.c 25 Nov 2005 01:41:59 -0000 1.32 +++ src/dumper.c 26 Nov 2005 13:07:42 -0000 ＠＠ -1672,11 +1672,6 ＠＠ retry_fwrite (data, sizeof (pdump_cv_data_dump_info), count, pdump_out); } -/* Dump out the root block pointers, part of stage 3 (the "WRITE" stage) of - dumping. For each pointer we dump out a structure containing the - location of the pointer and its value, replaced by the appropriate - offset into the dumped data. */ - static void pdump_dump_cv_ptr_info (void) { ＠＠ -1692,6 +1687,11 ＠＠ PDUMP_ALIGN_OUTPUT (pdump_cv_ptr_dump_info); retry_fwrite (data, sizeof (pdump_cv_ptr_dump_info), count, pdump_out); } + +/* Dump out the root block pointers, part of stage 3 (the "WRITE" stage) of + dumping. For each pointer we dump out a structure containing the + location of the pointer and its value, replaced by the appropriate + offset into the dumped data. */ static void pdump_dump_root_block_ptrs (void) -- School of Systems and Information Engineering http://turnbull.sk.tsukuba.ac.jp University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN Ask not how you can "do" free software business; ask what your business can "do for" free software.

1 participants
1 comments

[PATCH21.5] Incremental Garbage Collector 18 years, 4 months

Marcus Crestani

This patch introduces an incremental garbage collector for XEmacs. All changes to the code are conditioned on `NEW_GC'. To enable the new garbage collector, configure with `--enable-newgc'. The old garbage collector causes long pause times because it runs atomically while the client is stopped. The new incremental garbage collector makes XEmacs more reactive by interleaving small amounts of collection work with program execution. Garbage collection no longer interrupts the user's work, and using XEmacs feels smoother. Note that the new garbage collector does not run faster, because it still has to do the same amount of work the old collector has to do. But it shortens pause times by interrupting the collection. Please consider this patch as another step towards a new memory manager. The difficulty with incremental techniques is that, while the collector traverses the graph of reachable objects, the graph may change, as the running client may mutate the graph while the collector "is not looking". To prevent this from happening, a write barrier is needed. Detailed information about incremental techniques, write barrier theory, and the implementation of the new garbage collector can be found in my diploma thesis: http://www.crestani.de/xemacs/pdf/thesis-newgc.pdf This document also contains detailed performance and memory usage measurements. Below you can find a short summary of the incremental garbage collector, future prospects, and comments on the patch. Short summary ============= Write Barrier ------------- A write barrier is the most important prerequisite for fancy garbage collection techniques. I implement a "Virtual Dirty Bit (short: vdb) Write Barrier" that makes uses of the operating system's memory-protection mechanisms: The write barrier write-protects memory pages containing heap objects. If the mutator tries to modify these objects by writing into the write-protected page, the operating system generates a fault. The write barrier catches this fault, reads out the error-causing address and can thus identify the updated object and page. Not all environments and operating systems provide the mechanism to write-protect memory, catch resulting write faults, and read out the faulting address. But luckily, most of today's operating systems provide the features needed for the write-barrier implementation. My patch includes write-barrier implementations for the following platforms: - POSIX-compliant platforms like up-to-date UNIX, Linux, Solaris, etc. use the system call `mprotect' for memory protection, `sigaction' for signal handling and get the faulting address from `struct siginfo'. See file vdb-posix.c. - Mach-based systems like Mac OS X use "Mach Exception Handlers". See file vdb-mach.c. - Windows systems like native Windows and Cygwin use Microsoft's so-called "Structured Exception Handling". See file vdb-win32.c. The configure script determines which write barrier implementation to use for a system. If no write barrier implementation is working on that system, a fall-back "fake" implementation is used: This implementation simply turns of the incremental write barrier at runtime and does not allow any incremental collection (see vdb-fake.c). The garbage collector then acts like a traditional mark-and-sweep garbage collector. Generally, the incremental garbage collector can be turned of at runtime by the user or by applications, see below. I tested the write barrier and the new incremental garbage collector successfully on the following system: Linux (32bit-x86 and 64bit-x86), FreeBSD, Solaris, Mac OS X, native Windows, and Cygwin. I would appreciate more testing on these and other platforms. Memory Protection and Object Layout ----------------------------------- Implementations of a memory-protection mechanism may restrict the size and the alignment of the memory region to be on page-size boundaries. All objects subject to be covered by the write barrier have to be allocated on logical memory pages, so that they meet the requirement to be write-protected. The new allocator mc-alloc is aware of a system page size---it allocates all Lisp objects on logical memory pages and is therefore defaulted to on when the new garbage collector is enabled. Unfortunately, the current Lisp object layout leads to holes in the write barrier: Not all data structures containing pointers to Lisp objects are allocated on the Lisp heap. Some Lisp objects do not carry all their information in the object itself. External parts are kept in separately allocated memory blocks that are not managed by the new Lisp allocator. Examples for these objects are hash tables and dynamic arrays, two objects that can dynamically grow and shrink. The separate memory blocks are not guaranteed to reside on page boundaries, and thus cannot be watched by the write barrier. Moreover, the separate parts can contain live pointers to other Lisp objects. These pointers are not covered by the write barrier and modifications by the client during garbage collection do escape. In this case, the client changes the connectivity of the reachability graph behind the collector's back, which eventually leads to erroneous collection of live objects. To solve this problem, I transformed the separately allocated parts to fully qualified Lisp objects that are managed by the allocator and thus are covered by the write barrier. This also removes a lot of special allocation and removal code for the out-sourced parts. Generally, allocating all data structures that contain pointers to Lisp objects on one heap makes the whole memory layout more consistent. A large part of the patch converts these data structures to Lisp objects. The conversion of an additionally allocated data structure to an Lisp objects includes: - Add new object type to enum lrecord_type in lrecord.h. - Add lrecord_header to the object's struct. - Add DECLARE_RECORD()/XFOO/etc. below the struct definition. - Add lrecord definition. - Change allocation with malloc to allocation with new allocator. - Add object to syms_of_*(). - Change memory description of parent object. - Modify finalizer, free, or delete functions. This is a list of additionally allocated objects that I converted to Lisp objects: string_indirect_data, string_direct_data, hash_table_entry, dynarr, face_cachel, fache_cachel_dynarr, glyph_cachel, glyph_cachel_dynarr, syntax_cache, buffer_text, compiled_function_args, tty_console, stream_console, x_device, gtk_device, tty_device, mswindows_device, msprinter_device, x_frame, gtk_frame, mswindows_frame, gap_array_marker, gap_array, extent_list_marker, extent_list, stack_of_extents, tty_color_instance_data, tty_font_instance_data, specifier_caching, expose_ignore. More information about the dynarr object: Dynamic arrays are extensively used for separately allocated objects. In the old garbage collector, dynamic arrays held non-Lisp objects as well as Lisp objects. The new incremental garbage collector distinguishes between dynamic arrays that hold Lisp objects and dynamic arrays that hold non-Lisp objects. For dynamic arrays that hold Lisp objects, I created the new Lisp object type "Dynamic Lisp Array," called dynarr_lisp. It contains Lisp objects, in contrast to the dynamic array dynarr that contains non-Lisp objects. For dynamic Lisp arrays, the allocator has to be extended: I added two more primitives to the new allocator to allow allocation of elements in a contiguous block of memory: mc_alloc_array and alloc_lrecord_array. Each element in the array is a regular Lisp object with its own Lisp object header and mark bit. Debugging --------- The virtual-dirty-bit write barrier provokes signals on purpose, namely SIGSEGV and SIGBUS. When debugging XEmacs with this write barrier running, the debugger always breaks whenever a signal occurs. This behavior is generally desired: A debugger has to break on signals, to allow the user to examine the cause of the signal---especially for illegal memory access, which is a common programming error. But the debugger should not break for signals caused by the write barrier. Therefore, most debuggers provide the ability to turn of their fault handling for specific signals. XEmacs contains special configuration files for the debuggers gdb (.gdbinit) and dbx (.dbxrc). My changes remove these files from the source repository and adds `.gdbinit.in' and `.dbxrc.in'. The configure script generates from these files .gdbinit and .dbxrc, adding code to turn of signal handling for SIGSEGV and SIGBUS, if the new garbage collector is used. But what happens if a bug in XEmacs causes an illegal memory access? To maintain basic debugging abilities, I use another signal: First, the write-barrier signal handler has to determine if the current error situation is caused by the write-barrier memory protection or not. Therefore, the signal handler checks if the faulting address has been write-protected before. If it has not, the fault is caused by a bug; the debugger has to break in this situation. To achieve this, the signal handler raises SIGABRT to abort the program. Since SIGABRT is not masked out by the debugger, XEmacs aborts and allows the user to examine the problem. Incremental Garbage Collection ------------------------------ The new garbage collector is still a mark-and-sweep collector, but now the mark phase no longer runs in one atomic action, it is interleaved with program execution. The incremental garbage collector needs an explicit mark stack to store the state of the incremental traversal: the kkcc mark algorithm is a prerequisite and is enabled by default when the new garbage collector is on. Garbage collection is invoked as before: After `gc-cons-threshold' bytes have been allocated since the last garbage collection (or after `gc-cons-percentage' percentage of the total amount of memory used for Lisp data has been allocated since the last garbage collection) a collection starts. After some initialization, the marking begins. The variable `gc-incremental-traversal-threshold' contains how many steps of incremental work have to be executed in one incremental traversal cycle. After that many steps have been made, the mark phase is interrupted and the client resumes. Now, the Lisp memory is write-protected and the write barrier records modified objects. Incremental traversal is resumed after `gc-cons-incremental-threshold' bytes have been allocated since the interruption of garbage collection. Then, the objects recorded by the write-barrier have to be re-examined by the traversal, i.e. they are re-pushed onto the mark stack and processed again. Once the mark stack is empty, the traversal is done. A full incremental collection is slightly slower than a full garbage collection before: There is an overhead for storing pointers into objects when the write barrier is running, and an overhead for repeated traversal of modified objects. However, the new incremental garbage collector reduces client pause times to one-third, so even when a garbage collection is running, XEmacs stays reactive. Lisp Interface -------------- The new garbage collector can be accessed directly from Emacs Lisp. Basically, two functions invoke the garbage collector: (gc-full) starts a full garbage collection. If an incremental garbage collection is already running, it is finished without further interruption. This function guarantees that unused objects have been freed when it returns. (gc-incremental) starts an incremental garbage collection. If an incremental garbage collection is already running, the next cycle of incremental traversal is started. The garbage collection is finished if the traversal completes. Note that this function does not necessarily free any memory. It only guarantees that the traversal of the heap makes progress. The old garbage collector uses the function (garbage-collect) to invoke a garbage collection. This function is still in use by some applications that explicitly want to invoke a garbage collection. Since these applications may expect that unused memory has really been freed when (garbage-collect) returns, it maps to (gc-full). The new garbage collector is highly customizable during runtime; it can even be switched back to the traditional mark-and-sweep garbage collector: The variable allow-incremental-gc controls whether garbage collections may be interrupted or if they have to be carried out in one atomic action. Setting allow-incremental-gc to nil prevents incremental garbage collection, and the garbage collector then only does full collects, even if (gc-incremental) is called. Non-nil allows incremental garbage collection. This way applications can freely decide what garbage collection algorithm is best for the upcoming memory usage. How frequently a garbage collection occurs and how much traversal work is done in one incremental cycle can also be modified during runtime. See M-x customize RET alloc RET for a overview of all settings. Future prospects ================ The current patch is another step towards a modern memory manager, but there is plenty of work left to do: - Write barrier: The write barrier has to be tested on various systems. Implementations for more systems have to be added and more holes in the write barrier have to be found and fixed. This may involve that more data structures have to be converted to Lisp objects. - Garbage collection techniques: Once the write barrier works stable, more fancy garbage collection techniques can be implemented on top of it, for example a generational garbage collector. - Speed-up mark phase: The mark phase is currently the most costly part of a garbage collection. A basic re-design of the object layout by separating pointer-containing cells from no-pointer opaque data would speed up the mark phase. Comments on the patch ===================== - The new incremental garbage collector only works with MC_ALLOC and USE_KKCC. The configure script enables both, if the new garbage collector is enabled. - Big parts of the patch convert additionally allocated data structures to Lisp objects. - It adds new files for the write-barrier implementation: vdb.c, vdb.h, vdb-posix.c, vdb-mach.c, vdb-win32.c, and vdb-fake.c. The configure script determines, which implementation to use. - The patch removes .gdbinit and .dbxrc from the repository, they are now generated by the configure script from .gdbinit.in and .dbxrc.in. - It moves the garbage collection code from alloc.c to gc.c and gc.h. Note that all changes are conditioned on `NEW_GC', the code from alloc.c is not actually moved, it is turned off when `NEW_GC' is defined. I'll wait a week to give people the time to look over the patch and read the documentation before I'll commit it when nobody objects. I would appreciate extensive testing! Please report back! ChangeLog addition: 2005-11-07 Marcus Crestani <crestani(a)xemacs.org> 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. Generate .gdbinit and .dbxrc. lisp/ChangeLog addition: 2005-11-07 Marcus Crestani <crestani(a)xemacs.org> 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. nt/ChangeLog addition: 2005-11-07 Marcus Crestani <crestani(a)xemacs.org> 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. src/ChangeLog addition: 2005-11-07 Marcus Crestani <crestani(a)xemacs.org> 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 newgc_objs and vdb_objs. * alloc.c: Move the GC related code to gc.h. Left in alloc.c are the allocation functions, the definition of the lrecords, and root-set code like staticpro and mcpro. * 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. * 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 (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. * 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. Move dynamic array * 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: * 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. diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/configure newgc-xemacs-21.5/configure --- xemacs-21.5/configure 2005-11-07 11:08:21.000000000 +0100 +++ newgc-xemacs-21.5/configure 2005-11-07 10:36:46.000000000 +0100 ＠＠ -1016,6 +1016,7 ＠＠ applications. --with-kkcc Enable new GC algorithms. --with-mc-alloc Enable new allocator. + --with-newgc Enable new incremental garbage collector. --with-union-type Use union definition of Lisp_Object type. Known to trigger bugs in some compilers. --with-pdump Enable portable LISP preloader. ＠＠ -2702,6 +2703,22 ＠＠ 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; # If --with-union-type or --without-union-type were given then copy the value to the # equivalent enable_union-type variable. if test "${with_union_type+set}" = set; then ＠＠ -4352,6 +4369,22 ＠＠ esac fi +if test "$enable_newgc" = "yes"; 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 +fi + if test -z "$with_dynamic"; then case "$opsys" in hpux* | sunos4* ) with_dynamic=no ;; ＠＠ -8551,6 +8584,11 ＠＠ 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 "" ＠＠ -28502,6 +28540,654 ＠＠ 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 + ＠＠ -37140,14 +37826,14 ＠＠ 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 ＠＠ -37449,6 +38135,18 ＠＠ #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 ＠＠ -37750,6 +38448,29 ＠＠ 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 sigaction() to install fault handler." + else + echo " Using 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 ; 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 " WARNING: incremental garbage collection!" + echo " WARNING: Use \`--disable-newgc' to turn incremental gc off." + echo " WARNING: ---------------------------------------------------------" +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." ＠＠ -39174,6 +39895,70 ＠＠ 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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/configure.ac newgc-xemacs-21.5/configure.ac --- xemacs-21.5/configure.ac 2005-11-07 11:08:21.000000000 +0100 +++ newgc-xemacs-21.5/configure.ac 2005-11-07 10:36:47.000000000 +0100 ＠＠ -715,6 +715,9 ＠＠ XE_MERGED_ARG([mc-alloc], AC_HELP_STRING([--enable-mc-alloc],[Enable new allocator.]), [], [enable_mc_alloc=yes]) +XE_MERGED_ARG([newgc], + AC_HELP_STRING([--enable-newgc],[Enable new incremental garbage collector.]), + [], []) XE_MERGED_ARG([union-type], AC_HELP_STRING([--enable-union-type],[Use union definition of Lisp_Object type. Known to trigger bugs in some compilers.]), [], []) ＠＠ -1651,6 +1654,19 ＠＠ esac fi +if test "$enable_newgc" = "yes"; 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 +fi + if test -z "$with_dynamic"; then case "$opsys" in hpux* | sunos4* ) with_dynamic=no ;; ＠＠ -2012,6 +2028,12 ＠＠ 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 ＠＠ -4398,6 +4420,48 ＠＠ 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 ---------------------------------------------------------------- ＠＠ -5284,15 +5348,15 ＠＠ 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 ＠＠ -5550,6 +5614,9 ＠＠ 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) ＠＠ -5830,6 +5897,29 ＠＠ 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 sigaction() to install fault handler." + else + echo " Using 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 ; 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 " WARNING: incremental garbage collection!" + echo " WARNING: Use \`--disable-newgc' to turn incremental gc off." + echo " WARNING: ---------------------------------------------------------" +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." ＠＠ -5947,6 +6037,14 ＠＠ 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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/lisp/cus-start.el newgc-xemacs-21.5/lisp/cus-start.el --- xemacs-21.5/lisp/cus-start.el 2002-12-12 04:20:36.000000000 +0100 +++ newgc-xemacs-21.5/lisp/cus-start.el 2005-06-14 13:13:37.000000000 +0200 ＠＠ -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) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/lisp/diagnose.el newgc-xemacs-21.5/lisp/diagnose.el --- xemacs-21.5/lisp/diagnose.el 2005-10-15 02:03:33.000000000 +0200 +++ newgc-xemacs-21.5/lisp/diagnose.el 2005-11-02 04:35:32.000000000 +0100 ＠＠ -140,7 +140,7 ＠＠ (princ "\n") (map-plist #'(lambda (stat num) (when (string-match - "\$.*\$-storage\$-additional\$?$" + "\$.*\$-storage\\$" (symbol-name stat)) (incf total num) (princ (format fmt ＠＠ -235,10 +235,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)))) ＠＠ -251,10 +247,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) ＠＠ -370,9 +365,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") ＠＠ -397,3 +389,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))))) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/nt/config.inc.samp newgc-xemacs-21.5/nt/config.inc.samp --- xemacs-21.5/nt/config.inc.samp 2005-09-29 11:56:16.000000000 +0200 +++ newgc-xemacs-21.5/nt/config.inc.samp 2005-09-27 21:03:09.000000000 +0200 ＠＠ -223,6 +223,9 ＠＠ # 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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/nt/xemacs.dsp newgc-xemacs-21.5/nt/xemacs.dsp --- xemacs-21.5/nt/xemacs.dsp 2005-04-09 01:21:38.000000000 +0200 +++ newgc-xemacs-21.5/nt/xemacs.dsp 2005-06-20 12:18:54.000000000 +0200 ＠＠ -555,6 +555,14 ＠＠ # 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 ＠＠ -1339,6 +1347,18 ＠＠ # 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 + SOURCE="..\src\vm-limit.c" # End Source File # Begin Source File diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/nt/xemacs.mak newgc-xemacs-21.5/nt/xemacs.mak --- xemacs-21.5/nt/xemacs.mak 2005-10-29 13:47:11.000000000 +0200 +++ newgc-xemacs-21.5/nt/xemacs.mak 2005-11-02 13:20:09.000000000 +0100 ＠＠ -216,6 +216,9 ＠＠ !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 ＠＠ -637,9 +640,17 ＠＠ OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\unexnt.obj !endif +!if $(NEW_GC) +OPT_DEFINES=$(OPT_DEFINES) -DNEW_GC +OPT_OBJS=$(OPT_OBJS) $(OUTDIR)\gc.obj $(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 ＠＠ -1257,6 +1268,9 ＠＠ !if $(MC_ALLOC) Using new experimental allocator. !endif +!if $(NEW_GC) + Using new experimental incremental garbage collector. +!endif <<NOKEEP ＠echo -------------------------------------------------------------------- ＠type $(BLDROOT)\Installation diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/alloc.c newgc-xemacs-21.5/src/alloc.c --- xemacs-21.5/src/alloc.c 2005-10-29 13:47:19.000000000 +0200 +++ newgc-xemacs-21.5/src/alloc.c 2005-11-02 00:45:41.000000000 +0100 ＠＠ -52,6 +52,10 ＠＠ #include "extents-impl.h" #include "file-coding.h" #include "frame-impl.h" +#ifdef NEW_GC +#include "gc.h" +#include "vdb.h" +#endif /* NEW_GC */ #include "glyphs.h" #include "opaque.h" #include "lstream.h" ＠＠ -70,7 +74,9 ＠＠ EXFUN (Fgarbage_collect, 0); +#ifndef NEW_GC static void recompute_need_to_garbage_collect (void); +#endif /* not NEW_GC */ #if 0 /* this is _way_ too slow to be part of the standard debug options */ #if defined(DEBUG_XEMACS) && defined(MULE) ＠＠ -91,6 +97,7 ＠＠ static Fixnum debug_allocation_backtrace_length; #endif +#ifndef NEW_GC /* Number of bytes of consing done since the last gc */ static EMACS_INT consing_since_gc; EMACS_UINT total_consing; ＠＠ -98,6 +105,7 ＠＠ int total_gc_usage_set; int need_to_garbage_collect; +#endif /* not NEW_GC */ int need_to_check_c_alloca; int need_to_signal_post_gc; int funcall_allocation_flag; ＠＠ -149,6 +157,16 ＠＠ INCREMENT_CONS_COUNTER_1 (size) #endif +#ifdef NEW_GC +#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,7 +176,9 ＠＠ consing_since_gc = 0; \ recompute_need_to_garbage_collect (); \ } while (0) +#endif /*not NEW_GC */ +#ifndef NEW_GC /* Number of bytes of consing since gc before another gc should be done. */ static EMACS_INT gc_cons_threshold; ＠＠ -176,17 +196,18 ＠＠ 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]; +#endif /* not NEW_GC */ /* This is just for use by the printer, to allow things to print uniquely */ static int lrecord_uid_counter; +#ifndef NEW_GC /* Nonzero when calling certain hooks or doing other things where a GC would be bad */ int gc_currently_forbidden; ＠＠ -202,6 +223,7 ＠＠ Lisp_Object Qgarbage_collecting; static Lisp_Object QSin_garbage_collection; +#endif /* not NEW_GC */ /* Non-zero means we're in the process of doing the dump */ int purify_flag; ＠＠ -282,6 +304,7 ＠＠ 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,6 +544,13 ＠＠ } lrecord_stats [countof (lrecord_implementations_table) + MODULE_DEFINABLE_TYPE_COUNT]; +#ifdef NEW_GC +void +init_lrecord_stats () +{ + xzero (lrecord_stats); +} +#else /* not NEW_GC */ int lrecord_string_data_instances_in_use; int lrecord_string_data_bytes_in_use; int lrecord_string_data_bytes_in_use_including_overhead; ＠＠ -549,6 +579,7 ＠＠ lrecord_string_data_bytes_in_use -= size; lrecord_string_data_bytes_in_use_including_overhead -= size; } +#endif /* not NEW_GC */ void inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) ＠＠ -581,6 +612,17 ＠＠ 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 ＠＠ -614,6 +656,7 ＠＠ return lheader; } + void * noseeum_alloc_lrecord (Bytecount size, const struct lrecord_implementation *implementation) ＠＠ -636,15 +679,59 ＠＠ 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 */ ＠＠ -1834,7 +1921,11 ＠＠ 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 ＠＠ -2240,8 +2331,12 ＠＠ } 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 } }; ＠＠ -2312,6 +2407,10 ＠＠ 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 - \ ＠＠ -2343,8 +2442,10 ＠＠ #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) { ＠＠ -2371,9 +2472,58 ＠＠ 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; ＠＠ -2440,6 +2590,7 ＠＠ return s_chars; } +#endif /* not NEW_GC */ #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN void ＠＠ -2474,9 +2625,11 ＠＠ #ifdef MC_ALLOC s = alloc_lrecord_type (Lisp_String, &lrecord_string); +#ifndef NEW_GC #ifdef ALLOC_TYPE_STATS inc_lrecord_string_data_stats (length); #endif /* ALLOC_TYPE_STATS */ +#endif /* not NEW_GC */ #else /* not MC_ALLOC */ /* Allocate the string header */ ALLOCATE_FIXED_TYPE (string, Lisp_String, s); ＠＠ -2484,10 +2637,16 ＠＠ set_lheader_implementation (&s->u.lheader, &lrecord_string); #endif /* not MC_ALLOC */ +#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; ＠＠ -2509,7 +2668,11 ＠＠ void resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) { +#ifdef NEW_GC + Bytecount newfullsize; +#else /* not NEW_GC */ Bytecount oldfullsize, newfullsize; +#endif /* not NEW_GC */ #ifdef VERIFY_STRING_CHARS_INTEGRITY verify_string_chars_integrity (); #endif ＠＠ -2537,6 +2700,23 ＠＠ so convert this to the appropriate form. */ pos += -delta; +#ifdef NEW_GC + newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); + + Bytecount 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); ＠＠ -2629,6 +2809,7 ＠＠ } } } +#endif /* not NEW_GC */ XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); /* If pos < 0, the string won't be zero-terminated. ＠＠ -2860,9 +3041,11 ＠＠ #ifdef MC_ALLOC s = alloc_lrecord_type (Lisp_String, &lrecord_string); +#ifndef NEW_GC #ifdef ALLOC_TYPE_STATS inc_lrecord_string_data_stats (length); #endif /* ALLOC_TYPE_STATS */ +#endif /* not NEW_GC */ mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get collected and static data is tried to be freed. */ ＠＠ -2873,8 +3056,18 ＠＠ SET_C_READONLY_RECORD_HEADER (&s->u.lheader); #endif /* not MC_ALLOC */ 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); ＠＠ -3343,6 +3536,7 ＠＠ #endif /* not DEBUG_XEMACS */ #endif /* MC_ALLOC */ +#ifndef NEW_GC #ifdef ERROR_CHECK_GC #ifdef MC_ALLOC #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ ＠＠ -3849,7 +4043,7 ＠＠ if (! MARKED_RECORD_HEADER_P (lheader)) { MARK_RECORD_HEADER (lheader); - kkcc_gc_stack_push ((void*) lheader, desc, level, pos); + kkcc_gc_stack_push ((void *) lheader, desc, level, pos); } } } ＠＠ -4072,6 +4266,7 ＠＠ #endif } #endif /* USE_KKCC */ +#endif /* not NEW_GC */ /* Mark reference to a Lisp_Object. If the object referred to has not been seen yet, recursively mark all the references contained in it. */ ＠＠ -4801,6 +4996,7 ＠＠ #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 ＠＠ -4899,6 +5095,7 ＠＠ current_string_chars_block->next = 0; } } +#endif /* not NEW_GC */ #ifndef MC_ALLOC #if 1 /* Hack to debug missing purecopy's */ ＠＠ -4960,6 +5157,7 ＠＠ } #endif /* not MC_ALLOC */ +#ifndef NEW_GC /* I hate duplicating all this crap! */ int marked_p (Lisp_Object obj) ＠＠ -5070,6 +5268,7 ＠＠ #endif #endif /* not MC_ALLOC */ } +#endif /* not NEW_GC */ /* Clearing for disksave. */ ＠＠ -5107,11 +5306,16 ＠＠ #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. */ { ＠＠ -5128,11 +5332,13 ＠＠ } } } +#endif /* not NEW_GC */ /* There, that ought to be enough... */ } +#ifndef NEW_GC int begin_gc_forbidden (void) ＠＠ -5526,6 +5732,7 ＠＠ return; } +#endif /* not NEW_GC */ #ifdef ALLOC_TYPE_STATS ＠＠ -5579,6 +5786,7 ＠＠ pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); } } +#ifndef NEW_GC 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", ＠＠ -5586,6 +5794,7 ＠＠ pl = gc_plist_hack ("string-data-used", lrecord_string_data_instances_in_use, pl); tgu_val += lrecord_string_data_bytes_in_use_including_overhead; +#endif /* not NEW_GC */ #else /* not MC_ALLOC */ ＠＠ -5726,7 +5935,12 ＠＠ ()) { /* 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. */ ＠＠ -5825,6 +6039,7 ＠＠ need_to_signal_post_gc; } +#ifndef NEW_GC /* True if it's time to garbage collect now. */ static void recompute_need_to_garbage_collect (void) ＠＠ -5846,6 +6061,7 ＠＠ ); recompute_funcall_allocation_flag (); } +#endif /* not NEW_GC */ int ＠＠ -6013,11 +6229,15 ＠＠ Qnull_pointer = wrap_pointer_1 (0); #endif +#ifndef NEW_GC gc_generation_number[0] = 0; +#endif /* not NEW_GC */ #ifndef MC_ALLOC breathing_space = 0; #endif /* not MC_ALLOC */ +#ifndef NEW_GC Vgc_message = Qzero; +#endif /* not NEW_GC */ #ifndef MC_ALLOC all_lcrecords = 0; #endif /* not MC_ALLOC */ ＠＠ -6029,7 +6249,9 ＠＠ 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 (); ＠＠ -6087,11 +6309,14 ＠＠ #endif /* MC_ALLOC */ consing_since_gc = 0; +#ifndef NEW_GC need_to_garbage_collect = always_gc; +#endif /* not NEW_GC */ need_to_check_c_alloca = 0; funcall_allocation_flag = 0; funcall_alloca_count = 0; +#ifndef NEW_GC #if 1 gc_cons_threshold = 2000000; /* XEmacs change */ #else ＠＠ -6099,13 +6324,17 ＠＠ #endif gc_cons_percentage = 40; /* #### what is optimal? */ total_gc_usage_set = 0; +#endif /* not NEW_GC */ + lrecord_uid_counter = 259; #ifndef MC_ALLOC debug_string_purity = 0; #endif /* not MC_ALLOC */ +#ifndef NEW_GC gc_currently_forbidden = 0; gc_hooks_inhibited = 0; +#endif /* not NEW_GC */ #ifdef ERROR_CHECK_TYPES ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = ＠＠ -6173,6 +6402,10 ＠＠ 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); ＠＠ -6206,8 +6439,10 ＠＠ void syms_of_alloc (void) { +#ifndef NEW_GC DEFSYMBOL (Qpre_gc_hook); DEFSYMBOL (Qpost_gc_hook); +#endif /* not NEW_GC */ DEFSYMBOL (Qgarbage_collecting); DEFSUBR (Fcons); ＠＠ -6238,6 +6473,7 ＠＠ void vars_of_alloc (void) { +#ifndef NEW_GC QSin_garbage_collection = build_msg_string ("(in garbage collection)"); staticpro (&QSin_garbage_collection); ＠＠ -6280,6 +6516,7 ＠＠ See also `consing-since-gc' and `gc-cons-threshold'. */ ); +#endif /* not NEW_GC */ #ifdef DEBUG_XEMACS DEFVAR_INT ("debug-allocation", &debug_allocation /* ＠＠ -6300,6 +6537,7 ＠＠ This means that certain objects should be allocated in readonly space. */ ); +#ifndef NEW_GC DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /* Non-nil means display messages at start and end of garbage collection. */ ); ＠＠ -6338,10 +6576,13 ＠＠ Otherwise, a message will be printed in the echo area, as controlled by `gc-message'. */ ); +#endif /* not NEW_GC */ } +#ifndef NEW_GC void complex_vars_of_alloc (void) { Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); } +#endif /* not NEW_GC */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/buffer.c newgc-xemacs-21.5/src/buffer.c --- xemacs-21.5/src/buffer.c 2005-10-29 13:47:19.000000000 +0200 +++ newgc-xemacs-21.5/src/buffer.c 2005-10-29 13:53:27.000000000 +0200 ＠＠ -233,6 +233,14 ＠＠ { 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 ＠＠ { 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/buffer.h newgc-xemacs-21.5/src/buffer.h --- xemacs-21.5/src/buffer.h 2005-10-29 13:47:19.000000000 +0200 +++ newgc-xemacs-21.5/src/buffer.h 2005-10-29 13:53:27.000000000 +0200 ＠＠ -79,6 +79,9 ＠＠ 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. */ ＠＠ -138,6 +141,20 ＠＠ 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 { struct LCRECORD_HEADER header; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/bytecode.c newgc-xemacs-21.5/src/bytecode.c --- xemacs-21.5/src/bytecode.c 2005-04-09 01:21:43.000000000 +0200 +++ newgc-xemacs-21.5/src/bytecode.c 2005-11-02 10:34:13.000000000 +0100 ＠＠ -58,6 +58,45 ＠＠ #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 ＠＠ } 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 ＠＠ /************************************************************************/ /* The compiled-function object type */ /************************************************************************/ + static void print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) ＠＠ -2143,7 +2191,11 ＠＠ 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 ＠＠ 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 ＠＠ { 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 ＠＠ 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/bytecode.h newgc-xemacs-21.5/src/bytecode.h --- xemacs-21.5/src/bytecode.h 2005-03-03 00:40:40.000000000 +0100 +++ newgc-xemacs-21.5/src/bytecode.h 2005-05-23 14:52:49.000000000 +0200 ＠＠ -31,6 +31,32 ＠＠ #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 ＠＠ 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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/config.h.in newgc-xemacs-21.5/src/config.h.in --- xemacs-21.5/src/config.h.in 2005-10-29 13:47:20.000000000 +0200 +++ newgc-xemacs-21.5/src/config.h.in 2005-10-29 13:53:27.000000000 +0200 ＠＠ -414,6 +414,14 ＠＠ #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 ＠＠ -681,6 +689,15 ＠＠ /* 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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console.c newgc-xemacs-21.5/src/console.c --- xemacs-21.5/src/console.c 2005-10-29 13:47:21.000000000 +0200 +++ newgc-xemacs-21.5/src/console.c 2005-11-02 00:22:32.000000000 +0100 ＠＠ -115,9 +115,17 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-gtk-impl.h newgc-xemacs-21.5/src/console-gtk-impl.h --- xemacs-21.5/src/console-gtk-impl.h 2005-03-03 00:40:43.000000000 +0100 +++ newgc-xemacs-21.5/src/console-gtk-impl.h 2005-11-02 01:10:28.000000000 +0100 ＠＠ -49,6 +49,9 ＠＠ struct gtk_device { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ /* Gtk application info. */ GtkWidget *gtk_app_shell; ＠＠ -109,6 +112,17 ＠＠ #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_frame { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ + /* The widget of this frame. */ GtkWidget *widget; /* This is really a GtkWindow */ ＠＠ -182,6 +200,17 ＠＠ 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) #define FRAME_GTK_SHELL_WIDGET(f) (FRAME_GTK_DATA (f)->widget) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-msw-impl.h newgc-xemacs-21.5/src/console-msw-impl.h --- xemacs-21.5/src/console-msw-impl.h 2005-10-29 13:47:20.000000000 +0200 +++ newgc-xemacs-21.5/src/console-msw-impl.h 2005-11-02 01:10:28.000000000 +0100 ＠＠ -81,6 +81,9 ＠＠ 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 ＠＠ 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 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 ＠＠ 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 mswindows_frame { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ + /* win32 window handle */ HWND hwnd; ＠＠ -199,6 +231,17 ＠＠ 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) #define FRAME_MSWINDOWS_HANDLE(f) (FRAME_MSWINDOWS_DATA (f)->hwnd) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-stream.c newgc-xemacs-21.5/src/console-stream.c --- xemacs-21.5/src/console-stream.c 2005-03-03 00:40:44.000000000 +0100 +++ newgc-xemacs-21.5/src/console-stream.c 2005-06-14 12:39:10.000000000 +0200 ＠＠ -53,9 +53,17 ＠＠ { 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 ＠＠ 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 ＠＠ 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; } } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-stream.h newgc-xemacs-21.5/src/console-stream.h --- xemacs-21.5/src/console-stream.h 2005-03-03 00:40:44.000000000 +0100 +++ newgc-xemacs-21.5/src/console-stream.h 2005-06-10 01:27:48.000000000 +0200 ＠＠ -29,7 +29,9 ＠＠ #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; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-stream-impl.h newgc-xemacs-21.5/src/console-stream-impl.h --- xemacs-21.5/src/console-stream-impl.h 2005-03-03 00:40:43.000000000 +0100 +++ newgc-xemacs-21.5/src/console-stream-impl.h 2005-06-06 17:08:32.000000000 +0200 ＠＠ -34,6 +34,9 ＠＠ struct stream_console { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ FILE *in; FILE *out; FILE *err; ＠＠ -41,6 +44,17 ＠＠ 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) #endif /* INCLUDED_console_stream_impl_h_ */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-tty.c newgc-xemacs-21.5/src/console-tty.c --- xemacs-21.5/src/console-tty.c 2005-07-13 22:01:14.000000000 +0200 +++ newgc-xemacs-21.5/src/console-tty.c 2005-07-13 21:56:25.000000000 +0200 ＠＠ -59,16 +59,29 ＠＠ { 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 ＠＠ 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; } } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-tty-impl.h newgc-xemacs-21.5/src/console-tty-impl.h --- xemacs-21.5/src/console-tty-impl.h 2005-03-03 00:40:44.000000000 +0100 +++ newgc-xemacs-21.5/src/console-tty-impl.h 2005-11-02 01:00:50.000000000 +0100 ＠＠ -39,6 +39,9 ＠＠ 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 ＠＠ 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,6 +242,9 ＠＠ 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 ＠＠ -235,6 +252,17 ＠＠ #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) /* termcap requires this to be global */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/console-x-impl.h newgc-xemacs-21.5/src/console-x-impl.h --- xemacs-21.5/src/console-x-impl.h 2005-03-03 00:40:44.000000000 +0100 +++ newgc-xemacs-21.5/src/console-x-impl.h 2005-11-02 01:10:28.000000000 +0100 ＠＠ -42,6 +42,9 ＠＠ 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 ＠＠ 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_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 ＠＠ #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) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/.cvsignore newgc-xemacs-21.5/src/.cvsignore --- xemacs-21.5/src/.cvsignore 2005-06-28 14:05:42.000000000 +0200 +++ newgc-xemacs-21.5/src/.cvsignore 2005-11-02 12:10:08.000000000 +0100 ＠＠ -30,3 +30,5 ＠＠ dump-size xemacs.def xemacs.def.in +.dbxrc +.gdbinit diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/.dbxrc.in newgc-xemacs-21.5/src/.dbxrc.in --- xemacs-21.5/src/.dbxrc.in 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/.dbxrc.in 2005-07-28 21:02:23.000000000 +0200 ＠＠ -0,0 +1,395 ＠＠ +## -*- 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 +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/depend newgc-xemacs-21.5/src/depend --- xemacs-21.5/src/depend 2005-10-07 14:03:33.000000000 +0200 +++ newgc-xemacs-21.5/src/depend 2005-11-01 14:01:41.000000000 +0100 ＠＠ -11,7 +11,7 ＠＠ 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 ＠＠ 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 ＠＠ 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.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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/device.c newgc-xemacs-21.5/src/device.c --- xemacs-21.5/src/device.c 2005-10-29 13:47:21.000000000 +0200 +++ newgc-xemacs-21.5/src/device.c 2005-11-02 01:01:23.000000000 +0100 ＠＠ -86,12 +86,26 ＠＠ +#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 ＠＠ -102,6 +116,7 ＠＠ #ifdef HAVE_X_WINDOWS { XD_BLOCK_PTR, x_console, 1, { &x_device_data_description} }, #endif +#endif /* not NEW_GC */ { XD_END } }; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/device-gtk.c newgc-xemacs-21.5/src/device-gtk.c --- xemacs-21.5/src/device-gtk.c 2005-06-27 21:32:34.000000000 +0200 +++ newgc-xemacs-21.5/src/device-gtk.c 2005-11-02 00:58:48.000000000 +0100 ＠＠ -75,11 +75,19 ＠＠ { 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 ＠＠ 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/device-msw.c newgc-xemacs-21.5/src/device-msw.c --- xemacs-21.5/src/device-msw.c 2005-10-29 13:47:21.000000000 +0200 +++ newgc-xemacs-21.5/src/device-msw.c 2005-11-02 11:43:51.000000000 +0100 ＠＠ -73,11 +73,19 ＠＠ { 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 ＠＠ { 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 ＠＠ 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 ＠＠ #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 ＠＠ 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 ＠＠ 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 */ } } ＠＠ -1345,6 +1379,11 ＠＠ { 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); DEFSUBR (Fmsprinter_apply_settings); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/device-tty.c newgc-xemacs-21.5/src/device-tty.c --- xemacs-21.5/src/device-tty.c 2005-03-03 00:40:45.000000000 +0100 +++ newgc-xemacs-21.5/src/device-tty.c 2005-11-02 00:59:29.000000000 +0100 ＠＠ -44,10 +44,26 ＠＠ 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 ＠＠ call0 (Qinit_pre_tty_win); } +#ifndef NEW_GC static void free_tty_device_struct (struct device *d) { ＠＠ -109,6 +126,7 ＠＠ { free_tty_device_struct (d); } +#endif /* not NEW_GC */ #ifdef SIGWINCH ＠＠ -189,6 +207,10 ＠＠ 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 ＠＠ { /* 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 */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/device-x.c newgc-xemacs-21.5/src/device-x.c --- xemacs-21.5/src/device-x.c 2005-10-29 13:47:21.000000000 +0200 +++ newgc-xemacs-21.5/src/device-x.c 2005-11-02 00:59:38.000000000 +0100 ＠＠ -109,11 +109,19 ＠＠ { 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 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/dumper.c newgc-xemacs-21.5/src/dumper.c --- xemacs-21.5/src/dumper.c 2005-10-14 23:58:39.000000000 +0200 +++ newgc-xemacs-21.5/src/dumper.c 2005-11-02 00:46:26.000000000 +0100 ＠＠ -686,6 +686,12 ＠＠ } 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 ＠＠ } 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 ＠＠ } } +#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 ＠＠ * (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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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,24 ＠＠ 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)); + ((Rawbyte *) rdata + delta)); +#ifndef NEW_GC if (((const struct lrecord_header *) - ((char *) rdata + delta))->type + ((Rawbyte *) rdata + delta))->type == lrecord_type_string) inc_lrecord_string_data_stats - (((Lisp_String *) ((char *) rdata + delta))->size_); + (((Lisp_String *) + ((Rawbyte *) rdata + delta))->size_); +#endif /* not NEW_GC */ #endif /* ALLOC_TYPE_STATS */ } else ＠＠ -2182,7 +2276,7 ＠＠ 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 +2311,13 ＠＠ 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; ＠＠ -2320,6 +2414,10 ＠＠ xfree (pdump_mc_hash, mc_addr_elt *); #endif /* MC_ALLOC */ +#ifdef NEW_GC + allow_incremental_gc = allow_inc_gc; +#endif /* NEW_GC */ + return 1; } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/dynarr.c newgc-xemacs-21.5/src/dynarr.c --- xemacs-21.5/src/dynarr.c 2005-03-03 00:40:47.000000000 +0100 +++ newgc-xemacs-21.5/src/dynarr.c 2005-11-02 00:51:32.000000000 +0100 ＠＠ -150,6 +150,39 ＠＠ 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 ＠＠ /* 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 *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 diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/elhash.c newgc-xemacs-21.5/src/elhash.c --- xemacs-21.5/src/elhash.c 2005-10-29 13:47:22.000000000 +0200 +++ newgc-xemacs-21.5/src/elhash.c 2005-10-29 13:53:28.000000000 +0200 ＠＠ -96,6 +96,9 ＠＠ typedef struct htentry { +#ifdef NEW_GC + struct lrecord_header lheader; +#endif /* NEW_GC */ Lisp_Object key; Lisp_Object value; } htentry; ＠＠ -414,6 +417,12 ＠＠ #endif ) { +#ifdef NEW_GC + htentry *e, *sentinel; + + for (e = hentries, sentinel = e + size; e < sentinel; e++) + mc_free (e); +#else /* not NEW_GC */ #ifdef ERROR_CHECK_STRUCTURES /* Ensure a crash if other code uses the discarded entries afterwards. */ htentry *e, *sentinel; ＠＠ -424,6 +433,7 ＠＠ if (!DUMPEDP (hentries)) xfree (hentries, htentry *); +#endif /* not NEW_GC */ } static void ＠＠ -448,13 +458,39 ＠＠ 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 +608,13 ＠＠ 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 +1012,13 ＠＠ 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 +1043,13 ＠＠ 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 +1073,13 ＠＠ 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 +1093,11 ＠＠ 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 +1825,9 ＠＠ 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; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/elhash.h newgc-xemacs-21.5/src/elhash.h --- xemacs-21.5/src/elhash.h 2005-03-03 00:40:47.000000000 +0100 +++ newgc-xemacs-21.5/src/elhash.h 2005-05-18 09:25:53.000000000 +0200 ＠＠ -33,6 +33,19 ＠＠ #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, diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/emacs.c newgc-xemacs-21.5/src/emacs.c --- xemacs-21.5/src/emacs.c 2005-10-29 13:47:23.000000000 +0200 +++ newgc-xemacs-21.5/src/emacs.c 2005-11-07 11:12:29.000000000 +0100 ＠＠ -1312,6 +1312,9 ＠＠ 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,10 ＠＠ init_alloc_early (); +#ifdef NEW_GC + init_gc_early (); +#endif /* not NEW_GC */ + if (!initialized) { /* Initialize things so that new Lisp objects ＠＠ -1406,6 +1413,10 ＠＠ routines below create new objects. */ init_alloc_once_early (); +#ifdef NEW_GC + init_gc_once_early (); +#endif /* not NEW_GC */ + /* Initialize Qnil, Qt, Qunbound, and the obarray. After this, symbols can be interned. This depends on init_alloc_once_early(). */ ＠＠ -1444,6 +1455,10 ＠＠ #ifdef MC_ALLOC syms_of_mc_alloc (); #endif /* MC_ALLOC */ +#ifdef NEW_GC + syms_of_gc (); + syms_of_vdb (); +#endif /* NEW_GC */ syms_of_buffer (); syms_of_bytecode (); syms_of_callint (); ＠＠ -1850,6 +1865,9 ＠＠ (note, we are inside ifdef PDUMP) */ { reinit_alloc_early (); +#ifdef NEW_GC + reinit_gc_early (); +#endif /* not NEW_GC */ reinit_symbols_early (); #ifndef MC_ALLOC reinit_opaque_early (); ＠＠ -2054,6 +2072,9 ＠＠ vars_of_font_lock (); #endif /* USE_C_FONT_LOCK */ vars_of_frame (); +#ifdef NEW_GC + vars_of_gc (); +#endif /* NEW_GC */ vars_of_glyphs (); vars_of_glyphs_eimage (); vars_of_glyphs_widget (); ＠＠ -2393,8 +2414,10 ＠＠ complex_vars_of_glyphs_mswindows (); #endif +#ifndef NEW_GC /* This calls Fmake_glyph_internal(). */ complex_vars_of_alloc (); +#endif /* not NEW_GC */ /* This calls Fmake_glyph_internal(). */ #ifdef HAVE_MENUBARS ＠＠ -2439,6 +2462,10 ＠＠ might depend on all sorts of things; I'm not sure. */ complex_vars_of_emacs (); +#ifdef NEW_GC + complex_vars_of_gc (); +#endif /* NEW_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 +2476,11 ＠＠ { 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 +2959,11 ＠＠ { 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 +3239,11 ＠＠ 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 +3767,28 ＠＠ 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; } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/eval.c newgc-xemacs-21.5/src/eval.c --- xemacs-21.5/src/eval.c 2005-10-29 13:47:23.000000000 +0200 +++ newgc-xemacs-21.5/src/eval.c 2005-11-02 11:53:44.000000000 +0100 ＠＠ -2238,7 +2238,9 ＠＠ 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 ＠＠ 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 ＠＠ { #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 ＠＠ 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 ＠＠ { 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 ＠＠ { 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 ＠＠ /* 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)); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/event-msw.c newgc-xemacs-21.5/src/event-msw.c --- xemacs-21.5/src/event-msw.c 2005-10-29 13:47:23.000000000 +0200 +++ newgc-xemacs-21.5/src/event-msw.c 2005-10-29 13:53:29.000000000 +0200 ＠＠ -2498,9 +2498,11 ＠＠ 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) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/events.c newgc-xemacs-21.5/src/events.c --- xemacs-21.5/src/events.c 2005-10-29 13:47:23.000000000 +0200 +++ newgc-xemacs-21.5/src/events.c 2005-10-29 13:53:29.000000000 +0200 ＠＠ -2643,6 +2643,9 ＠＠ reinit_vars_of_events (void) { Vevent_resource = Qnil; +#ifdef NEW_GC + staticpro (&Vevent_resource); +#endif /* NEW_GC */ } void diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/extents.c newgc-xemacs-21.5/src/extents.c --- xemacs-21.5/src/extents.c 2005-10-29 13:47:24.000000000 +0200 +++ newgc-xemacs-21.5/src/extents.c 2005-11-02 01:05:42.000000000 +0100 ＠＠ -242,6 +242,9 ＠＠ 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 { +#ifdef NEW_GC + struct lrecord_header header; +#endif /* NEW_GC */ Elemcount gap; Elemcount gapsize; Elemcount numels; ＠＠ -281,7 +287,9 ＠＠ 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 ＠＠ 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 { +#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 ＠＠ 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 ＠＠ 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_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 ＠＠ } 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 ＠＠ 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_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 ＠＠ 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_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 ＠＠ } 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 ＠＠ 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 ＠＠ 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_gap_array (el->end); xfree (el, Extent_List *); } +#endif /* not NEW_GC */ /************************************************************************/ ＠＠ -1021,28 +1077,46 ＠＠ 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 ＠＠ { 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 ＠＠ 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 ＠＠ free_extent_list (data->extents); data->extents = 0; } +#endif /* not NEW_GC */ } DEFINE_LRECORD_IMPLEMENTATION ("extent-info", extent_info, ＠＠ -1181,7 +1321,9 ＠＠ if (data->soe) { +#ifndef NEW_GC free_soe (data->soe); +#endif /* not NEW_GC */ data->soe = 0; } } ＠＠ -1326,12 +1468,16 ＠＠ 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/extents.h newgc-xemacs-21.5/src/extents.h --- xemacs-21.5/src/extents.h 2005-03-03 00:40:51.000000000 +0100 +++ newgc-xemacs-21.5/src/extents.h 2005-11-02 01:06:01.000000000 +0100 ＠＠ -49,6 +49,56 ＠＠ #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 { diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/faces.h newgc-xemacs-21.5/src/faces.h --- xemacs-21.5/src/faces.h 2005-10-29 13:47:24.000000000 +0200 +++ newgc-xemacs-21.5/src/faces.h 2005-11-02 00:54:44.000000000 +0100 ＠＠ -117,6 +117,9 ＠＠ 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 ＠＠ -222,6 +225,19 ＠＠ 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) #define wrap_face(p) wrap_record (p, face) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/frame.c newgc-xemacs-21.5/src/frame.c --- xemacs-21.5/src/frame.c 2005-10-29 13:47:25.000000000 +0200 +++ newgc-xemacs-21.5/src/frame.c 2005-11-02 01:09:04.000000000 +0100 ＠＠ -139,11 +139,24 ＠＠ +#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 ＠＠ -153,6 +166,7 ＠＠ #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 ＠＠ 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 ＠＠ 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 ＠＠ { 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 ＠＠ --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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/frame-gtk.c newgc-xemacs-21.5/src/frame-gtk.c --- xemacs-21.5/src/frame-gtk.c 2005-03-03 00:40:53.000000000 +0100 +++ newgc-xemacs-21.5/src/frame-gtk.c 2005-11-02 01:03:02.000000000 +0100 ＠＠ -102,11 +102,19 ＠＠ { 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 ＠＠ 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/frame-msw.c newgc-xemacs-21.5/src/frame-msw.c --- xemacs-21.5/src/frame-msw.c 2005-10-29 13:47:25.000000000 +0200 +++ newgc-xemacs-21.5/src/frame-msw.c 2005-11-02 01:03:12.000000000 +0100 ＠＠ -92,11 +92,19 ＠＠ { 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 ＠＠ 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 ＠＠ #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 ＠＠ void syms_of_frame_mswindows (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (mswindows_frame); +#endif /* NEW_GC */ } void diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/frame-x.c newgc-xemacs-21.5/src/frame-x.c --- xemacs-21.5/src/frame-x.c 2005-05-05 02:30:57.000000000 +0200 +++ newgc-xemacs-21.5/src/frame-x.c 2005-11-02 01:03:24.000000000 +0100 ＠＠ -77,11 +77,19 ＠＠ { 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 ＠＠ 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 ＠＠ 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 ＠＠ void syms_of_frame_x (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (x_frame); +#endif /* NEW_GC */ + DEFSYMBOL (Qoverride_redirect); DEFSYMBOL (Qx_resource_name); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/gc.c newgc-xemacs-21.5/src/gc.c --- xemacs-21.5/src/gc.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/gc.c 2005-11-07 11:11:57.000000000 +0100 ＠＠ -0,0 +1,1959 ＠＠ +/* 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; + +/* 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; + +/* Percentage of consing of total data size before another GC. */ +EMACS_INT gc_cons_percentage; + +/* Number of elements marked in one cycle of incremental GC. */ +EMACS_INT gc_incremental_traversal_threshold; + +/* Nonzero during gc */ +int gc_in_progress; + +/* Nonzero during write barrier */ +int write_barrier_enabled; + + + +/************************************************************************/ +/* 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 */ + + +/************************************************************************/ +/* 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 = write_barrier_enabled ? + (consing_since_gc > gc_cons_incremental_threshold) : + (consing_since_gc > gc_cons_threshold) && + (!total_gc_usage_set || + (100 * consing_since_gc) / total_gc_usage >= + gc_cons_percentage); + recompute_funcall_allocation_flag (); +} + + + +/************************************************************************/ +/* Mark Phase */ +/************************************************************************/ + +#if 0 +# define KKCC_STACK_AS_QUEUE +#endif + +#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 + +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 +}; + +/* 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); +#ifdef 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 *); + case XD_LISP_OBJECT_BLOCK_PTR: + 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); + } +} + +#define GC_CHECK_NOT_FREE(lheader) \ + gc_checking_assert (! LRECORD_FREE_P (lheader)); + +/* The following functions implement the new mark algorithm. + They mark objects according to their descriptions. They + are modeled on the corresponding pdumper procedures. */ + +#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 +{ + GC_STAT_ENQUEUED; + 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; + GC_STAT_DEQUEUED; +#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)) + { + MARK_GREY (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 + +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); + } +} + +#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 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 + +/* 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 (int cnt) +{ + kkcc_gc_stack_entry *stack_entry = 0; + void *data = 0; + const struct memory_description *desc = 0; + int pos; + int count = cnt; +#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); + + /* 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); + + 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; + mark_object_maybe_checking_free (*stored_obj, 0, level, pos); + 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; + mark_object_maybe_checking_free + (*stored_obj, 0, level, pos); + } + break; + } + 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; + } + 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 (); + } + } + + if (cnt) + if (!--count) + break; + } +} + +/* 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; +} + + + +/************************************************************************/ +/* Finalization */ +/************************************************************************/ + + + +/************************************************************************/ +/* Sweep Phase */ +/************************************************************************/ + + + +/************************************************************************/ +/* 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; + +void +gc_prepare (void) +{ + GC_STAT_START_NEW_GC; + GC_SET_PHASE (INIT_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; + + /* Do some totally ad-hoc resource clearing. */ + /* #### generalize this? */ + clear_event_resource (); + cleanup_specifiers (); + cleanup_buffer_undo_lists (); +} + +void +gc_mark_root_set (enum gc_phase phase) +{ + GC_SET_PHASE (phase); + /* Mark all the special slots that serve as the roots of accessibility. */ + +#define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) + + { /* 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++; + } + + { /* mcpro () */ + Lisp_Object *p = Dynarr_begin (mcpros); + Elemcount count; + for (count = Dynarr_length (mcpros); count; count--) + mark_object (*p++); + } + + { /* 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 (); +#undef mark_object +} + +void +gc_finish_mark (void) +{ + GC_SET_PHASE (FINISH_MARK); + init_marking_ephemerons (); + + while (finish_marking_weak_hash_tables () > 0 || + finish_marking_weak_lists () > 0 || + continue_marking_ephemerons () > 0) + { + kkcc_marking (0); + } + + /* 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) + { + kkcc_marking (0); + } + + /* 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 (); +} + +void +gc_finalize (void) +{ + GC_SET_PHASE (FINALIZE); + mc_finalize (); +} + +void +gc_sweep (void) +{ + GC_SET_PHASE (SWEEP); + mc_sweep (); +} + + +void +gc_finish (void) +{ + GC_SET_PHASE (FINISH_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 (); + + 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); + } + } + } + } + + need_to_signal_post_gc = 1; + funcall_allocation_flag = 1; + + PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); + + GC_SET_PHASE (NONE); +} + +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 (); +#if 1 // REPUSHED_OBJECTS_MAX + mark_work = (gc_incremental_traversal_threshold > repushed_objects) ? + gc_incremental_traversal_threshold : repushed_objects; +#else // REPUSHED_OBJECTS_SUM + mark_work = gc_incremental_traversal_threshold + repushed_objects; +#endif + 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); +} + +void +gc_incremental (void) +{ + gc (allow_incremental_gc); +} + +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; +} + +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; +} + + +/************************************************************************/ +/* 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_incremental_threshold = GC_CONS_INCREMENTAL_THRESHOLD; + gc_incremental_traversal_threshold = GC_INCREMENTAL_TRAVERSAL_THRESHOLD; +} + +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); + DEFSUBR (Fgc_full); + DEFSUBR (Fgc_incremental); +#ifdef ERROR_CHECK_GC + DEFSUBR (Fgc_stats); +#endif /* not ERROR_CHECK_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-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-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'. +*/ ); + + DEFVAR_INT ("gc-incremental-traversal-threshold", + &gc_incremental_traversal_threshold /* +*Number of elements processed in one cycle of incremental travesal. +*/ ); + + 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'. +*/ ); + + 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). +*/ ); +} + +void +complex_vars_of_gc (void) +{ + Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/gc.h newgc-xemacs-21.5/src/gc.h --- xemacs-21.5/src/gc.h 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/gc.h 2005-11-01 16:39:35.000000000 +0100 ＠＠ -0,0 +1,146 ＠＠ +/* 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 + + +/************************************************************************/ +/* 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 */ + + + +/************************************************************************/ +/* Global Variables */ +/************************************************************************/ +/* Enable/disable incremental garbage collection during runtime. */ +extern int allow_incremental_gc; + +/* 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; + +/* 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; + +/* Percentage of consing of total data size before another GC. */ +extern EMACS_INT gc_cons_percentage; + +/* Nonzero during gc */ +extern int gc_in_progress; + +/* Nonzero during write barrier */ +extern int write_barrier_enabled; + + + +/************************************************************************/ +/* Prototypes */ +/************************************************************************/ + +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 + + +/* 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); + + +/* 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); + +END_C_DECLS + +#endif /* INCLUDED_gc_h_ */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/.gdbinit.in newgc-xemacs-21.5/src/.gdbinit.in --- xemacs-21.5/src/.gdbinit.in 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/.gdbinit.in 2005-07-28 21:02:35.000000000 +0200 ＠＠ -0,0 +1,529 ＠＠ +## -*- 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 + diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/glyphs.c newgc-xemacs-21.5/src/glyphs.c --- xemacs-21.5/src/glyphs.c 2005-10-29 13:47:26.000000000 +0200 +++ newgc-xemacs-21.5/src/glyphs.c 2005-11-02 01:09:31.000000000 +0100 ＠＠ -4540,10 +4540,12 ＠＠ 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 ＠＠ 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 ＠＠ { 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 ＠＠ 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; } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/glyphs.h newgc-xemacs-21.5/src/glyphs.h --- xemacs-21.5/src/glyphs.h 2005-10-29 13:47:26.000000000 +0200 +++ newgc-xemacs-21.5/src/glyphs.h 2005-11-02 01:10:04.000000000 +0100 ＠＠ -1067,6 +1067,9 ＠＠ 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 ＠＠ 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,11 +1195,23 ＠＠ 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); extern int hold_ignored_expose_registration; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/lisp.h newgc-xemacs-21.5/src/lisp.h --- xemacs-21.5/src/lisp.h 2005-10-29 13:47:28.000000000 +0200 +++ newgc-xemacs-21.5/src/lisp.h 2005-11-07 11:10:43.000000000 +0100 ＠＠ -1253,6 +1253,7 ＠＠ /* ------------------------ dynamic arrays ------------------- */ +#ifndef NEW_GC #ifdef ERROR_CHECK_STRUCTURES #define Dynarr_declare(type) \ type *base; \ ＠＠ -1380,6 +1381,7 ＠＠ 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_Image_Instance Lisp_Image_Instance; /* glyphs.h */ typedef struct Lisp_Gui_Item Lisp_Gui_Item; +#ifndef NEW_GC /* ------------------------------- */ /* Dynarr typedefs */ /* ------------------------------- */ ＠＠ -1550,6 +1553,7 ＠＠ { Dynarr_declare (struct console_type_entry); } console_type_entry_dynarr; +#endif /* not NEW_GC */ /* ------------------------------- */ /* enum typedefs */ ＠＠ -1666,6 +1670,7 ＠＠ #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 ＠＠ { 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 ＠＠ 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 ＠＠ /*------------------------------ 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 ＠＠ #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; ＠＠ -2328,14 +2678,30 ＠＠ 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) ＠＠ -3519,6 +3885,9 ＠＠ extern Lisp_Object_ptr_dynarr *staticpros; +#ifdef NEW_GC +extern Lisp_Object_ptr_dynarr *staticpros_nodump; +#endif /* NEW_GC */ #ifdef DEBUG_XEMACS /* Help debug crashes gc-marking a staticpro'ed object. */ ＠＠ -3628,7 +3997,9 ＠＠ 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); ＠＠ -3643,7 +4014,9 ＠＠ 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); ＠＠ -3664,6 +4037,7 ＠＠ 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); ＠＠ -3677,6 +4051,7 ＠＠ #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; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/lrecord.h newgc-xemacs-21.5/src/lrecord.h --- xemacs-21.5/src/lrecord.h 2005-10-29 13:47:28.000000000 +0200 +++ newgc-xemacs-21.5/src/lrecord.h 2005-11-07 11:12:27.000000000 +0100 ＠＠ -211,38 +211,38 ＠＠ #### 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, ＠＠ -254,47 +254,79 ＠＠ 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; ＠＠ -394,6 +426,11 ＠＠ LHEADER_IMPLEMENTATION (XRECORD_LHEADER (obj)) #define LHEADER_IMPLEMENTATION(lh) lrecord_implementations_table[(lh)->type] +#ifdef NEW_GC +#include "gc.h" +#include "vdb.h" +#endif /* NEW_GC */ + extern int gc_in_progress; #ifdef MC_ALLOC ＠＠ -401,14 +438,35 ＠＠ #ifdef ALLOC_TYPE_STATS void init_lrecord_stats (void); +#ifndef NEW_GC void inc_lrecord_string_data_stats (Bytecount size); void dec_lrecord_string_data_stats (Bytecount size); +#endif /* not NEW_GC */ 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); \ ＠＠ -422,6 +480,7 ＠＠ 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) \ ＠＠ -946,6 +1005,9 ＠＠ { XD_LISP_OBJECT_ARRAY, XD_LISP_OBJECT, +#ifdef NEW_GC + XD_LISP_OBJECT_BLOCK_PTR, +#endif /* not NEW_GC */ XD_LO_LINK, XD_OPAQUE_PTR, XD_OPAQUE_PTR_CONVERTIBLE, ＠＠ -1082,6 +1144,14 ＠＠ { 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. */ ＠＠ -1668,6 +1738,9 ＠＠ 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)) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/Makefile.in.in newgc-xemacs-21.5/src/Makefile.in.in --- xemacs-21.5/src/Makefile.in.in 2005-10-29 13:47:19.000000000 +0200 +++ newgc-xemacs-21.5/src/Makefile.in.in 2005-10-29 13:53:26.000000000 +0200 ＠＠ -255,6 +255,19 ＠＠ mc_alloc_objs=mc-alloc.o #endif +#ifdef NEW_GC +new_gc_objs=vdb.o gc.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. ＠＠ -278,7 +291,7 ＠＠ 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)\ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/mc-alloc.c newgc-xemacs-21.5/src/mc-alloc.c --- xemacs-21.5/src/mc-alloc.c 2005-11-03 00:14:48.000000000 +0100 +++ newgc-xemacs-21.5/src/mc-alloc.c 2005-11-03 00:20:49.000000000 +0100 ＠＠ -21,17 +21,43 ＠＠ /* 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 ＠＠ 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 ＠＠ 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 ＠＠ #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 ＠＠ /* 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 ＠＠ #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 ＠＠ /*--- 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 ＠＠ } 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 ＠＠ 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 ＠＠ /* Different list types. */ enum list_type_enum { USED_LIST, - UNMANAGED_LIST, FREE_LIST }; ＠＠ -339,20 +294,19 ＠＠ /* 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 ＠＠ #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 ＠＠ # 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 ＠＠ #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 ＠＠ #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 ＠＠ /************************************************************************/ -/* ###TODO### */ -#if 1 -# define ALLOC_MB_UNMANAGED 1 -#endif - - /*--- misc functions ---------------------------------------------------*/ /* moved here from alloc.c */ ＠＠ -483,7 +438,7 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ 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 ＠＠ /*--- 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 ＠＠ 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 ＠＠ /* 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 ＠＠ /*--- 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 ＠＠ /* 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 ＠＠ 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 ＠＠ 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,10 +787,26 ＠＠ /*--- 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; + MC_MALLOCED_BYTES += malloced_storage_size (0, sizeof (page_header), 0); + 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) { ＠＠ -839,7 +815,6 ＠＠ #ifdef MEMORY_USAGE_STATS MC_MALLOCED_BYTES += malloced_storage_size (0, sizeof (page_header), 0); #endif - } else { ＠＠ -847,6 +822,7 ＠＠ PAGE_HEADER_FREE_LIST = NEXT_FREE (result); } return result; +#endif /* not BLOCKTYPE_ALLOC_PAGE_HEADER */ } ＠＠ -854,11 +830,15 ＠＠ static void free_page_header (page_header *ph) { +#ifdef BLOCKTYPE_ALLOC_PAGE_HEADER + return 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 +920,22 ＠＠ 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 +946,8 ＠＠ } -/* 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 +964,7 ＠＠ /* 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 +1002,8 ＠＠ 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 +1184,23 ＠＠ /*--- 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 +1228,7 ＠＠ /* 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 +1238,21 ＠＠ 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 +1269,11 ＠＠ { 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 +1352,7 ＠＠ 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 +1371,15 ＠＠ /* 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 +1387,56 ＠＠ /* 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 +1480,11 ＠＠ 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 +1501,31 ＠＠ 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 +1548,6 ＠＠ 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 +1578,46 ＠＠ 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 +1637,22 ＠＠ void mc_free (void *ptr) { - page_header *ph = get_page_header (ptr); + 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_ON_FREE_LIST_P (ph)); +#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 +1665,32 ＠＠ /* 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 +1700,12 ＠＠ } 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 +1713,51 ＠＠ void init_mc_allocator (void) { - int i; + EMACS_INT i; memset (&mc_allocator_globals, '\0', sizeof (mc_allocator_globals_type)); - for (i = 0; i < N_USED_PAGE_LISTS; 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; #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 = 0; #endif + + /* init of pagesize dependent values */ + switch (SYS_PAGE_SIZE) + { + 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 + 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 +1787,12 ＠＠ #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 +1811,11 ＠＠ { 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 +1824,6 ＠＠ 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 +1847,8 ＠＠ 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 +1862,198 ＠＠ 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 */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/mc-alloc.h newgc-xemacs-21.5/src/mc-alloc.h --- xemacs-21.5/src/mc-alloc.h 2005-10-14 23:58:41.000000000 +0200 +++ newgc-xemacs-21.5/src/mc-alloc.h 2005-11-02 22:02:30.000000000 +0100 ＠＠ -41,25 +41,81 ＠＠ -/* 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 +131,9 ＠＠ /* 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 +146,12 ＠＠ /* 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 ＠＠ -116,6 +161,39 ＠＠ 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 #endif /* INCLUDED_mc_alloc_h_ */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/objects.c newgc-xemacs-21.5/src/objects.c --- xemacs-21.5/src/objects.c 2005-10-29 13:47:29.000000000 +0200 +++ newgc-xemacs-21.5/src/objects.c 2005-11-02 12:01:31.000000000 +0100 ＠＠ -63,7 +63,11 ＠＠ 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 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 } }; diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/objects-tty.c newgc-xemacs-21.5/src/objects-tty.c --- xemacs-21.5/src/objects-tty.c 2005-03-03 00:41:02.000000000 +0100 +++ newgc-xemacs-21.5/src/objects-tty.c 2005-11-02 01:06:54.000000000 +0100 ＠＠ -42,18 +42,36 ＠＠ { 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 ＠＠ } /* 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 ＠＠ 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 ＠＠ } /* 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 ＠＠ 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 ＠＠ 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); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/objects-tty-impl.h newgc-xemacs-21.5/src/objects-tty-impl.h --- xemacs-21.5/src/objects-tty-impl.h 2005-03-03 00:41:02.000000000 +0100 +++ newgc-xemacs-21.5/src/objects-tty-impl.h 2005-11-02 01:07:06.000000000 +0100 ＠＠ -29,9 +29,25 ＠＠ 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,9 +55,25 ＠＠ 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) diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/print.c newgc-xemacs-21.5/src/print.c --- xemacs-21.5/src/print.c 2005-10-29 13:47:30.000000000 +0200 +++ newgc-xemacs-21.5/src/print.c 2005-11-02 00:48:47.000000000 +0100 ＠＠ -1733,6 +1733,17 ＠＠ 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 ＠＠ lheader, l->data_); break; } +#endif /* not NEW_GC */ } } diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/specifier.c newgc-xemacs-21.5/src/specifier.c --- xemacs-21.5/src/specifier.c 2005-10-29 13:47:31.000000000 +0200 +++ newgc-xemacs-21.5/src/specifier.c 2005-11-02 01:08:16.000000000 +0100 ＠＠ -302,7 +302,11 ＠＠ /* 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 ＠＠ { 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 ＠＠ { 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 ＠＠ 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 ＠＠ syms_of_specifier (void) { INIT_LRECORD_IMPLEMENTATION (specifier); +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (specifier_caching); +#endif /* NEW_GC */ DEFSYMBOL (Qspecifierp); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/specifier.h newgc-xemacs-21.5/src/specifier.h --- xemacs-21.5/src/specifier.h 2005-10-29 13:47:31.000000000 +0200 +++ newgc-xemacs-21.5/src/specifier.h 2005-11-02 01:08:02.000000000 +0100 ＠＠ -423,6 +423,9 ＠＠ 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); ＠＠ -432,6 +435,19 ＠＠ 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! */ /* #### I think the following should ABORT() rather than return nil diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/syntax.c newgc-xemacs-21.5/src/syntax.c --- xemacs-21.5/src/syntax.c 2005-10-29 13:47:31.000000000 +0200 +++ newgc-xemacs-21.5/src/syntax.c 2005-10-29 13:53:33.000000000 +0200 ＠＠ -309,10 +309,19 ＠＠ { 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 ＠＠ 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 ＠＠ 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 ＠＠ void syms_of_syntax (void) { +#ifdef NEW_GC + INIT_LRECORD_IMPLEMENTATION (syntax_cache); +#endif /* NEW_GC */ DEFSYMBOL (Qsyntax_table_p); DEFSYMBOL (Qsyntax_table); diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/syntax.h newgc-xemacs-21.5/src/syntax.h --- xemacs-21.5/src/syntax.h 2005-03-03 00:41:08.000000000 +0100 +++ newgc-xemacs-21.5/src/syntax.h 2005-05-23 12:49:58.000000000 +0200 ＠＠ -295,6 +295,9 ＠＠ 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 ＠＠ -333,6 +336,21 ＠＠ 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; /* Note that the external interface to the syntax-cache uses charpos's, but diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb.c newgc-xemacs-21.5/src/vdb.c --- xemacs-21.5/src/vdb.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb.c 2005-11-01 17:48:51.000000000 +0100 ＠＠ -0,0 +1,157 ＠＠ +/* 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; + + /* 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 ()); + Elemcount count; + 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); +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb-fake.c newgc-xemacs-21.5/src/vdb-fake.c --- xemacs-21.5/src/vdb-fake.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb-fake.c 2005-11-01 17:49:01.000000000 +0100 ＠＠ -0,0 +1,50 ＠＠ +/* 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 *ptr, EMACS_INT len) +{ + fake_error (); +} + +void +vdb_unprotect (void *ptr, EMACS_INT len) +{ + fake_error (); +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb.h newgc-xemacs-21.5/src/vdb.h --- xemacs-21.5/src/vdb.h 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb.h 2005-11-01 16:21:59.000000000 +0100 ＠＠ -0,0 +1,70 ＠＠ +/* 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_ */ diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb-mach.c newgc-xemacs-21.5/src/vdb-mach.c --- xemacs-21.5/src/vdb-mach.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb-mach.c 2005-11-01 17:48:56.000000000 +0100 ＠＠ -0,0 +1,261 ＠＠ +/* 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 (); + } +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb-posix.c newgc-xemacs-21.5/src/vdb-posix.c --- xemacs-21.5/src/vdb-posix.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb-posix.c 2005-11-01 19:34:38.000000000 +0100 ＠＠ -0,0 +1,153 ＠＠ +/* 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 (); + } +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/vdb-win32.c newgc-xemacs-21.5/src/vdb-win32.c --- xemacs-21.5/src/vdb-win32.c 1970-01-01 01:00:00.000000000 +0100 +++ newgc-xemacs-21.5/src/vdb-win32.c 2005-11-01 17:49:07.000000000 +0100 ＠＠ -0,0 +1,100 ＠＠ +/* 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); +} diff -NaurX diff-exclude-gen -x ChangeLog xemacs-21.5/src/window.c newgc-xemacs-21.5/src/window.c --- xemacs-21.5/src/window.c 2005-10-29 13:47:33.000000000 +0200 +++ newgc-xemacs-21.5/src/window.c 2005-11-02 00:53:27.000000000 +0100 ＠＠ -181,40 +181,80 ＠＠ { 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 ＠＠ { 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 ＠＠ 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 ＠＠ /* 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 (); ＠＠ -5377,6 +5440,12 ＠＠ { 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); -- Marcus

3 participants
11 comments

Patch missed? 18 years, 4 months

Rick Rankin

I submitted a patch about a week ago for building 21.5 on Cygwin, and I've seen no comment one way or the other about it. See http://list-archive.xemacs.org/xemacs-patches/200511/msg00092.html The patch is about as trivial as can be (a one-liner), but XEmacs won't build on Cygwin without it if modules are enabled. Since I've been reading about an impending release, I thought I'd better bring it up now. Is no one currently doing anything with Cygwin? --Rick

4 participants
5 comments

Re: [QUERY] [COMMIT] [21.4] Fix bugs in nt.c, sysdep.c 18 years, 4 months

Vin Shelton

On 11/26/05, Ben Wing <ben(a)666.com> wrote: > the new_ change is there because i removed a previous kludge to support > c++; no change needed in 21.4. > > "dup2 bitrot" means that this code (for ancient systems that don't have > dup2) was bitrotted; obviously no one has needed it for years. we > should probably just nuke it instead. I haven't heard any complaints wrt 21.4, so I don't think any change is needed there. Thanks for the clarification. - Vin

1 participants
0 comments

← Newer
1
2
3
4
5
6
7
...
12
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

XEmacs-Patches November 2005